Question

我正在尝试导出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

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

Answer 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

VBA导出到文本文件。需要使用范围

1 个答案: