Excel VBA复制查询将表单中的数据复制到文本文件

Question

我有一个小代码，它可以从工作表中复制行1-300中的所有文本，然后将其保存为UTF-8格式的文本文件。我希望它展开，所以它只从文本行复制文本。我不是VBA的人，请帮助我。

Sub tgr() 

Dim oStream As Object 
Dim sTextPath As String 
Dim sText As String 
Dim rIndex As Long, cIndex As Long 

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

For rIndex = 1 To 300 
    If rIndex > 1 Then sText = sText & vbNewLine 
    For cIndex = 1 To Columns("BC").Column 
    If cIndex > 1 Then sText = sText & vbTab 
    sText = sText & Sheets("IMPORT-SHEET").Cells(rIndex, cIndex).Text 
    Next cIndex 
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 tgr() 

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

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

sText = "" 

For rIndex = 1 To 300 
    sLine = "" 
    For cIndex = 1 To Columns("BC").Column 
    If cIndex > 1 Then 
     sLine = sLine & vbTab 
    End If 
    sLine = sLine & Sheets("IMPORT-SHEET").Cells(rIndex, cIndex).Text 
    Next cIndex 
    If Not Len(Trim(Replace(sLine, vbTab, ""))) = 0 Then 
    If rIndex > 1 Then 
     sText = sText & vbNewLine & sLine 
    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