vba - 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