0

我正在尝试导出位于 B 列中的 2 个条目之间的一系列行，这些条目是使用提示手动输入的。例如，提示会询问我第一个和第二个搜索词，我会输入 cat 然后 dog。B5 有单词 cat，B50 有单词 dog。我想捕获第 6 到 49 行，然后将其通过下面的内容并将输出发送到文本文件。

Sub ExportColumnsABToText()

Dim oStream As Object
Dim sTextPath As Variant
Dim sText As String
Dim sText2 As String
Dim sLine As String
Dim sType As String
Dim rIndex As Long, cIndex As Long

sTextPath = Application.GetSaveAsFilename("export.txt", "Text Files, *.txt")
If sTextPath = False Then Exit Sub

sText = ""

For rIndex = 4 To 700
    sLine = ""
    sType = Sheets![worksheet1].Cells(rIndex, 8).Text

            If sType = "A" Or sType = "CNAME" Then
        For cIndex = 1 To 2
            If cIndex > 1 Then
                sLine = sLine & vbTab
            End If
                sLine = sLine & Sheets![worksheet1].Cells(rIndex, cIndex).Text
        Next cIndex
        If Not Len(Trim(Replace(sLine, vbTab, ""))) = 0 Then
            If rIndex > 4 Then
                sText = sText & IIf(sText = "", "", vbNewLine) & sLine
            End If
        End If
    End If
    ' End If

Next rIndex


Set oStream = CreateObject("ADODB.Stream")
With oStream
  .Type = 2
  .Charset = "UTF-8"
  .Open
  .WriteText sText
  .SaveToFile sTextPath, 2
  .Close
End With

Set oStream = Nothing

End Sub

4

1 回答 1

1

试试下面的代码

Sub ExportColumnsABToText()


    Dim rngFind As Range, rngStart As Range, rngEnd As Range, rngPrint As Range, cell As Range
    Dim Criteria1, Criteria2
    Dim sTextPath

    sTextPath = Application.GetSaveAsFilename("export.txt", "Text Files, *.txt")
    If sTextPath = False Then Exit Sub

    Set rngFind = Columns("B")

    Criteria1 = InputBox("Enter first criteria")
    Criteria2 = InputBox("Enter Second criteria")

    If Criteria1 = "" Or Criteria2 = "" Then
        MsgBox "Please enter both criteria"
        Exit Sub
    End If

    Set rngStart = rngFind.Find(What:=Criteria1, LookIn:=xlValues)
    Set rngEnd = rngFind.Find(What:=Criteria2, LookIn:=xlValues)

    If rngStart Is Nothing Then
        MsgBox "Criteria1 not found"
        Exit Sub
    ElseIf rngEnd Is Nothing Then
        MsgBox "Criteria2 not found"
        Exit Sub
    End If


    Dim FileNum As Integer
    Dim str_text As String
    Dim i As Integer, j As Integer

    FileNum = FreeFile

    For i = (rngStart.Row + 1) To (rngEnd.Row - 1)
        For j = 1 To 26
            str_text = str_text & " " & Cells(i, j)
        Next

        Open sTextPath For Append As #FileNum    ' creates the file if it doesn't exist
        Print #FileNum, str_text    ' write information at the end of the text file
        Close #FileNum
        str_text = ""
    Next

End Sub
于 2013-11-01T05:21:05.287 回答