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

Excel VBA复制查询将数据从工作表复制到文本文件

1 个答案: