VBA導出爲文本文件。需要使用一個範圍

Question

我想輸出一系列落在B列中的2個條目之間的行，這些條目是使用提示手動輸入的。例如，提示會要求我輸入第一個和第二個搜索詞，然後輸入cat，然後輸入狗。 B5有單詞貓，B50有單詞狗。我想要捕獲第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

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