0

行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
4

1 に答える 1

0

これを試してください。テキストが含まれていないすべての行を除外する必要があります。

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
于 2013-03-05T12:45:11.260 に答える