宏导出从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