将Excel工作表保存为不带自动双引号分隔符的制表符分隔文本文件

Question

我正在编写一个宏将文本文件下载到Excel中，筛选出不必要的数据并将修改的文本文件保存在本地。

一切正常，但本地编写的文件引用了某些文本的引号（“），我认为这与可能被看作分隔符的逗号有关，是这种情况，如果有的话解决下面我的代码

注：我有一个运行GetHtmlTable和KillLoop程序按钮这里

Option Explicit 
Public StopLoop As Boolean 
Sub GetHtmlTable() 
StopLoop = False 
Do Until StopLoop = True 
DoEvents 
    Dim objWeb As QueryTable 

    Sheets(1).Columns(1).ClearContents 

    With Sheets("Sheet1") 
     Set objWeb = .QueryTables.Add(_ 
     Connection:="URL;http://www.spotternetwork.org/feeds/gr.txt", _ 
     Destination:=.Range("A1")) 
     With objWeb 
      .WebSelectionType = xlSpecifiedTables 
      .WebTables = "1" ' Identify your HTML Table here 
      .Refresh BackgroundQuery:=False 
      .SaveData = True 
     End With 
    End With 
    Set objWeb = Nothing 


'End Import of Text From http://www.spotternetwork.org/feeds/gr.txt================== 
'Start Filter Out Unused Data======================================================== 
Dim i As Long 
Dim j As Long 
Dim LRow As Long 
Dim LListRow As Long 
Dim BMatch As Boolean 

'Find last instance of "End:" in 
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row 
'Find last non-blank row in column A of second sheet 
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

If LRow >= 11 Then 
    'Make sure there are at least 11 rows of data 
    i = LRow 
    'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line 
    Do 
     BMatch = False 
     For j = 1 To LListRow 
      'Test this block to see if the value from j appears in the second row of data 
      If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then 
       BMatch = True 
       Exit For 
      End If 
     Next j 
     'Application.StatusBar = "Match status for row " & i & ": " & BMatch 
     If Not BMatch Then 
      'Loop backwards to find the starting row (no lower than 11) 
      For j = i To 11 Step -1 
       If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For 
      Next j 
      Sheets(1).Rows(j & ":" & i).Delete 
      i = j - 1 
     Else 
      'Find next block 
      If i > 11 Then 
       For j = i - 1 To 11 Step -1 
        If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For 
       Next j 
       i = j 
      Else 
       i = 10 'Force the loop to exit 
      End If 
     End If 
     'Application.StatusBar = "Moving to row " & i 
    Loop Until i < 11 

    'Loop back through and delete any blank rows 
    LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 
    'MsgBox "Second checkpoint: new last row of data is " & LRow 
    For i = LRow To 11 Step -1 
     If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete 
    Next i 
End If 

'Application.StatusBar = False 
Application.EnableEvents = True 
Application.DisplayAlerts = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

'End Filter Out Unused Data======================================================== 
'Start Write To Local Txt File===================================================== 
Dim sSaveAsFilePath As String 
Application.DisplayAlerts = False 


    sSaveAsFilePath = "C:\Users\Speedy\Desktop\Test\test.txt" 

    Sheets(1).Copy '//Copy sheet 1 to new workbook 
    ActiveWorkbook.SaveAs sSaveAsFilePath, xlTextWindows '//Save as text (tab delimited) file 
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then '//Double sure we don't close this workbook 
     ActiveWorkbook.Close False 
    End If 
Application.DisplayAlerts = True 
Application.Wait (Now + TimeValue("0:00:05")) 
Loop 
End Sub 

Sub KillMacro() 
    StopLoop = True ' stop that perpetual loop in Workbook_Open() 
    MsgBox "Program Stopped" 
End Sub 

Answer 1

你最好的选择将是使用VBA将数据写入到一个文本文件，而不是将工作簿另存为文本文件。

考虑下面的修改代码：

Option Explicit 
Public StopLoop As Boolean 
Sub GetHtmlTable() 
StopLoop = False 
Do Until StopLoop = True 
    DoEvents 
    Dim objWeb As QueryTable 

    Sheets(1).Columns(1).ClearContents 

    With Sheets("Sheet1") 
     Set objWeb = .QueryTables.Add(_ 
     Connection:="URL;http://www.spotternetwork.org/feeds/gr.txt", _ 
     Destination:=.Range("A1")) 
     With objWeb 
      .WebSelectionType = xlSpecifiedTables 
      .WebTables = "1" ' Identify your HTML Table here 
      .Refresh BackgroundQuery:=False 
      .SaveData = True 
     End With 
    End With 
    Set objWeb = Nothing 


    'End Import of Text From http://www.spotternetwork.org/feeds/gr.txt================== 
    'Start Filter Out Unused Data======================================================== 
    Dim i As Long 
    Dim j As Long 
    Dim LRow As Long 
    Dim LListRow As Long 
    Dim BMatch As Boolean 

    'Find last instance of "End:" in 
    LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row 
    'Find last non-blank row in column A of second sheet 
    LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 

    If LRow >= 11 Then 
     'Make sure there are at least 11 rows of data 
     i = LRow 
     'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line 
     Do 
      BMatch = False 
      For j = 1 To LListRow 
       'Test this block to see if the value from j appears in the second row of data 
       If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then 
        BMatch = True 
        Exit For 
       End If 
      Next j 
      'Application.StatusBar = "Match status for row " & i & ": " & BMatch 
      If Not BMatch Then 
       'Loop backwards to find the starting row (no lower than 11) 
       For j = i To 11 Step -1 
        If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For 
       Next j 
       Sheets(1).Rows(j & ":" & i).Delete 
       i = j - 1 
      Else 
       'Find next block 
       If i > 11 Then 
        For j = i - 1 To 11 Step -1 
         If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For 
        Next j 
        i = j 
       Else 
        i = 10 'Force the loop to exit 
       End If 
      End If 
      'Application.StatusBar = "Moving to row " & i 
     Loop Until i < 11 

     'Loop back through and delete any blank rows 
     LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 
     'MsgBox "Second checkpoint: new last row of data is " & LRow 
     For i = LRow To 11 Step -1 
      If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete 
     Next i 
    End If 

    'Application.StatusBar = False 
    Application.EnableEvents = True 
    Application.DisplayAlerts = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 

    'End Filter Out Unused Data======================================================== 
    'Start Write To Local Txt File===================================================== 
    Dim sSaveAsFilePath As String 
    Application.DisplayAlerts = False 


    sSaveAsFilePath = "C:\Users\Speedy\Desktop\Test\test.txt" 

    'Delete file if it exists 
    On Error Resume Next 
    Kill sSaveAsFilePath 
    On Error GoTo 0 

    'Open file for writing 
    LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 
    Dim iFile As Integer 
    iFile = FreeFile() 
    Open sSaveAsFilePath For Output As #iFile 
    For i = 1 To LRow 
     Print #iFile, Sheets(1).Range("A" & i).Value2 
    Next i 

    Close #iFile 
    Application.DisplayAlerts = True 
    Application.Wait (Now + TimeValue("0:00:05")) 'Uncomment this line 
Loop 
End Sub 

Sub KillMacro() 
    StopLoop = True ' stop that perpetual loop in Workbook_Open() 
    MsgBox "Program Stopped" 
End Sub