将dynamic范围复制到新的工作簿，添加标题，并在closures之前将新工作簿保存到本地目录

我有一张主工作簿，需要将其分成许多工作簿，每个工作簿都有一个工作表。

这些新创build的工作簿将在“主”工作表中的行在B列中具有相同内容时创build。

我需要将这些工作簿保存到同一个特定的本地目录中，文件名是列B的内容“.csv”，以使文件成为CSV文件而不是XLSX文件。

这是我到目前为止（很多这从另一个upvoted线程在这个网站有一些调整我）。

Sub Splitter() Dim Master As Workbook Set Master = Workbooks("Master").Worksheets("Master") 'This declares the target worksheet. last = 1 For i = 1 To 2000 'This defines the amount of rows If Range("B" & i) <> Range("B" & (i + 1)) Then Range("A" & last & ":F" & i).Copy Set NewBook = Workbooks.Add NewBook.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues Rows(1).EntireRow.Insert Shift:=xlDown Range("A1").Value = "Header1" Range("B1").Value = "Header2" Range("C1").Value = "Header3" Range("D1").Value = "Header4" Range("E1").Value = "Header5" Range("F1").Value = "Header6" last = i + 1 Master.Activate End If Next i End Sub 

此代码将从“主”工作簿中创build数百个（如果不是数千个）具有单个工作表的工作簿。

我在这里遇到几个问题：

1. 此代码：

    Rows(1).EntireRow.Insert Shift:=xlDown Range("A1").Value = "Header1" Range("B1").Value = "Header2" Range("C1").Value = "Header3" Range("D1").Value = "Header4" Range("E1").Value = "Header5" Range("F1").Value = "Header6" 

   似乎是正确添加标题行，但似乎是复制电子表格的整个内容，并粘贴到下一个可用的行 。 然后覆盖第1行的内容。

   示例：macros将以下行拖到一个新的工作簿：

    Bat Bat Bat 

   当上面的代码段运行时，最终的产品是：

    Header Bat Bat Bat Bat Bat 

   它似乎在复制内容，然后粘贴到第1行。

2. 前面提到的第二个问题是，新创build的工作簿/工作表不会自动保存（CSV）并closures，我需要自己closures/保存。

   他们似乎正在创build正确（除了问题＃1的问题）。 他们只是开放，我需要命名和保存所有这些。 由于我确信会有很多新创build的工作簿，这种function的缺乏会使我的生活变得非常困难。

---

任何帮助，将不胜感激。 我对此相当陌生，但我很快就select了它。

我对这篇长文章表示歉意，希望尽可能清楚，不要浪费读者的时间。

Answer 1

1. 因为你仍然在Range("A" & last & ":F" & i).Copy 。复制.Insert将再次插入复制的行。 因此， Rows(1).EntireRow.Insert之前放置一个Application.CutCopyMode = False以停止再次插入复制的行。

2. 您需要Workbook.SaveAs Method和Workbook.Close Method来保存和closures工作簿。

    NewBook.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local) NewBook.Close(SaveChanges, Filename, RouteWorkbook) 

   例如。 这应该工作：

    NewBook.SaveAs FileName:="C:\Temp\MyFileName.csv", FileFormat:=xlCSV NewBook.Close SaveChanges:=False 

3. 您应该使用Master.Rows()或NewBook.Worksheets("Sheet1").Range()这样的工作表指定任何Rows()和Range() NewBook.Worksheets("Sheet1").Range()以便在哪个工作簿\工作表中清除范围/行。 那么你不需要Master.Activate

Answer 2

什么想法这个代码。

 Sub Splitter() Dim Master As Workbook Dim n As Integer Dim strFile As String Set Master = Workbooks("Master").Worksheets("Master") 'This declares the target worksheet. last = 1 For i = 1 To 2000 'This defines the amount of rows If Range("B" & i) <> Range("B" & i + 1) Then strFile = ThisWorkbook.Path & "\" & Range("b" & i) & ".csv" TransToCSV strFile, Range("A" & last & ":F" & i) last = i + 1 End If Next i End Sub Sub TransToCSV(myfile As String, rng As Range) Dim vDB, vR() As String, vTxt() Dim i As Long, n As Long, j As Integer Dim objStream Dim strTxt As String, strHeader As String strHeader = "Header1,Header2,Header3,Header4,Header5,Header6" & vbCrLf Set objStream = CreateObject("ADODB.Stream") vDB = rng For i = 1 To UBound(vDB, 1) n = n + 1 ReDim vR(1 To UBound(vDB, 2)) For j = 1 To UBound(vDB, 2) vR(j) = vDB(i, j) Next j ReDim Preserve vTxt(1 To n) vTxt(n) = Join(vR, ",") Next i strTxt = strHeader & Join(vTxt, vbCrLf) With objStream '.Charset = "utf-8" .Open .WriteText strTxt .SaveToFile myfile, 2 .Close End With Set objStream = Nothing End Sub