宏導出從Excel文件中的文本文件與多個工作表

Question

我需要將在一個Excel文件導出一個工作表，以便它們是用逗號看起來像這樣分隔的文本文件宏：

場，場，場，場景場場場場場場場場場場場場場場場領域場場場場場場場場下面的宏運行在一個文件上，但需要它執行以下操作：

1）它應該在具有多個工作表的Excel文件中的活動打開工作表上運行。 2）應提示用戶使用唯一名稱保存新文本文件。 3）將文本文件放置在桌面上或指定的文件夾中。

這裏的宏：

Sub WriteCSVFile() 

Dim ws As Worksheet 
Dim fName As String, Txt1 As String 
Dim fRow As Long, lRow As Long, Rw As Long 
Dim Col As Long 

Set ws = Sheets("Sheet1") 
fName = "C:\yourpath\yourfilename.csv" 
fRow = 2 
Col = 2 
Txt1 = "" 

    With ws 
     lRow = .Cells(Rows.Count, Col).End(xlUp).Row 

     Open fName For Output As #1 

      For Rw = fRow To lRow 
       Txt1 = .Range(.Cells(Rw, Col), .Cells(Rw, Col)) 
        If Rw = lRow Then 
         Print #1, Txt1 
        Else 
         Print #1, Txt1 & ", "; 
        End If 
      Next Rw 

     Close #1 

     MsgBox ".csv file exported" 

    End With 
End Sub 

的問題與上面的是我不得不修改每個工作表的宏。我想要一些可以在任何打開的工作表上修改的東西。

Answer 1

試試這個：

Sub WriteCSVFile() 

Dim ws As Worksheet 
Dim fName As String, Txt1 As String 
Dim fRow As Long, lRow As Long, Rw As Long 
Dim Col As Long 

For Each ws In ActiveWorkbook.Sheets 
    fName = Application.GetSaveAsFilename("C:\yourpath\" & ws.Name & ".csv") 
    fRow = 2 
    Col = 2 
    Txt1 = "" 
    With ws 
     lRow = .Cells(Rows.Count, Col).End(xlUp).Row 

     Open fName For Output As #1 

      For Rw = fRow To lRow 
       Txt1 = .Range(.Cells(Rw, Col), .Cells(Rw, Col)) 
        If Rw = lRow Then 
         Print #1, Txt1 
        Else 
         Print #1, Txt1 & ", "; 
        End If 
      Next Rw 

     Close #1 

     MsgBox ".csv file exported" 

    End With 
Next ws 
End Sub 

它通過循環工作簿中的牀單和打開與當前工作表名作爲缺省的GetSaveAsFileName對話框。

Answer 2

並與Dave的確認，幾個點綴。將允許您在關閉它之前打開源文件並遍歷所有工作表。 .csv文件的文件名與工作表的Tab名稱相同（因此不需要用戶提示）。該代碼將「導出」的日誌條目寫入ThisWorkbook中名爲「日誌」的工作表。

在此代碼中添加您自己的'fOutPath'，並將名爲「Log」的工作表添加到您將存儲/運行此代碼的文件中。假定源數據在每個工作表中的相同位置，在從（fRow，Col）開始的單列中，當前設置爲「B2」。

Sub WriteCSVFile2() 

Dim wb As Workbook 
Dim ws As Worksheet 
Dim fd As Object 
Dim fOutName As String, fInName As String 
Dim fOutPath As String, Txt1 As String 
Dim fRow As Long, lRow As Long, Rw As Long 
Dim Col As Long, logNextRow As Long, logCol As Long 

fOutPath = yourpath 
logCol = 1 'col A 

'Open file select dialog 
Set fd = Application.FileDialog(msoFileDialogOpen) 
fd.AllowMultiSelect = False 
fd.Show 
fInName = fd.SelectedItems(1) 

    If Not fInName = "" Then 
     'Open the source data file; need a check if this wbook is already open 
     Set wb = Workbooks.Open(fInName) 

      'Iterate through the sheets collection to write data to .csv file(s) 
      For Each ws In Worksheets 
       'Set csv output file name as ws Tab name 
       fOutName = fOutPath & ws.Name & ".csv" 
       'You could 'detect' fRow and Col from the worksheet? 
       fRow = 2 
       Col = 2 
       Txt1 = "" 
        'Write csv file for this sheet 
        With ws 
         lRow = .Cells(Rows.Count, Col).End(xlUp).Row 

         Open fOutName For Output As #1 

          For Rw = fRow To lRow 
           Txt1 = .Range(.Cells(Rw, Col), .Cells(Rw, Col)) 
            If Rw = lRow Then 
             Print #1, Txt1 
            Else 
             Print #1, Txt1 & ", "; 
            End If 
          Next Rw 

         Close #1 
        End With 

        'Write an Output Log to a Sheet called "Log" 
        With ThisWorkbook.Sheets("Log") 
         logNextRow = .Cells(.Rows.Count, logCol).End(xlUp).Row + 1 
         .Cells(logNextRow, logCol).Value = "From: " & wb.Name 
         .Cells(logNextRow, logCol).Offset(0, 1).Value = _ 
         " To: " & fOutPath & ws.Name & ".csv" 
         .Cells(logNextRow, logCol).Offset(0, 2).Value = Now() 
         .Range(.Cells(logNextRow, logCol), .Cells(logNextRow, logCol).Offset(0, 2)).Columns.AutoFit 
        End With 

      Next ws 

     'Close source data workbook 
     wb.Close SaveChanges:=False 

     'Confirm export to user 
     MsgBox ".csv file(s) exported" 

    End If 

End Sub