vba 从一个源工作表创建多个工作表或工作簿

Creating multiple worksheets or workbooks from one source worksheet

提问by fonzy16

I have a spreadsheet with over a thousand rows. The unique identifier is the vendor ID which is located in column B. The data covers from column A to column N. I want to parse this master spreadsheet and create new worksheets or better yet create a new file/workbook by each vendor ID. The spreadsheet does not contain headers. A vendor ID may just have one row or it can have 20 rows of data, 3 rows of data, etc. Lastly, I would like to convert the new file into .CSV format. When creating the new worksheets or files I would like the maintain all the formats from the source spreadsheet. The data contains, amounts, dates, and regular input of characters.

我有一个超过一千行的电子表格。唯一标识符是位于 B 列中的供应商 ID。数据涵盖从 A 列到 N 列。我想解析这个主电子表格并创建新工作表，或者更好的是通过每个供应商 ID 创建一个新文件/工作簿。电子表格不包含标题。供应商 ID 可能只有一行，也可能有 20 行数据、3 行数据等。最后，我想将新文件转换为 .CSV 格式。创建新工作表或文件时，我希望保留源电子表格中的所有格式。数据包含金额、日期和字符的常规输入。

I found the below code on-line a few days ago and modified it for my needs. I was able to get it to work but I do not like how it brings over the .value and I lose the format of the dates and it creates formatting issues for the end result.

几天前我在网上找到了下面的代码，并根据我的需要修改了它。我能够让它工作，但我不喜欢它如何带来 .value 并且我丢失了日期的格式并且它为最终结果创建了格式问题。

I would like to build a code flexible enough where I can modify it to create multiple worksheets within the workbook (with or without headers) or have it flexible enough where I can modify it to create workbooks based off of each vendor ID criteria (or unique criteria if it is used for other purposes). I'm trying to prevent for a user to have to create 168 files or worksheets manually based off of a consolidated worksheet.

我想构建一个足够灵活的代码，我可以修改它以在工作簿中创建多个工作表（有或没有标题），或者让它足够灵活，我可以修改它以根据每个供应商 ID 标准（或唯一用于其他目的的标准）。我试图阻止用户必须根据合并的工作表手动创建 168 个文件或工作表。

Sub AllocatedataCSV()
    Dim ws As Worksheet
    Set ws = Sheets("CSV Master")
    Dim LastRow As Long

    LastRow = Range("B" & ws.Rows.Count).End(xlUp).Row

    ' stop processing if we don't have any data
    If LastRow < 2 Then Exit Sub

    Application.ScreenUpdating = False
    CopyDataToSheets LastRow, ws
    ws.Select
    Application.ScreenUpdating = True
End Sub


Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
    Dim rng As Range
    Dim cell As Range
    Dim Series As String
    Dim SeriesStart As Long
    Dim SeriesLast As Long

    Set rng = Range("B1:B" & LastRow)
    SeriesStart = 2
    Series = Range("B" & SeriesStart)
    For Each cell In rng
        If cell.Value <> Series Then
            SeriesLast = cell.Row - 1
            CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
            Series = cell.Value
            SeriesStart = cell.Row
        End If
    Next
    ' copy the last series
    SeriesLast = LastRow
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series

End Sub

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
                                                        name As String)
    Dim tgt As Worksheet

    If (SheetExists(name)) Then
        MsgBox "Sheet " & name & " already exists. " _
        & "Please delete or move existing sheets before" _
        & " copying data from the Master List.", vbCritical, _
        "Time Series Parser"
        End
    End If

    Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
    Set tgt = Sheets(name)


    ' copy data from src to tgt
    tgt.Range("A1:N" & Last).Value = _
    src.Range("A" & Start & ":N" & Last).Value
End Sub

Function SheetExists(name As String) As Boolean
    Dim ws As Worksheet

    SheetExists = True
    On Error Resume Next
    Set ws = Sheets(name)
    If ws Is Nothing Then
       SheetExists = False
    End If
End Function

采纳答案by Joe

To copy data and formatting, change:

要复制数据和格式，请更改：

tgt.Range("A1:N" & Last).Value = _
src.Range("A" & Start & ":N" & Last).Value

to:

到：

src.Range("A" & Start & ":N" & Last).Copy
tgt.Range("A1").PasteSpecial xlPasteAll

To put the copied data into a new workbook:

要将复制的数据放入新工作簿：

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
                                                        name As String)

    Dim wb As Workbook : Set wb = Workbooks.Add
    Dim tgt As Worksheet

    Set tgt = wb.Sheets(1)
    tgt.name = name

    src.Range("A" & Start & ":N" & Last).Copy
    tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll
    wb.SaveAs name
    wb.Close
End Sub

UPDATEto answer question in comment

更新以回答评论中的问题

If a source series has only one row, the pasted result will be incorrect. This can be resolved by pasting onto a single cell, so

如果源系列只有一行，则粘贴的结果将不正确。这可以通过粘贴到单个单元格来解决，所以

tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll

tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll

becomes

变成

tgt.Range("A1").PasteSpecial xlPasteAll

tgt.Range("A1").PasteSpecial xlPasteAll

I've updated my code above to reflect this change.

我已经更新了上面的代码以反映此更改。

This can also be resolved in the original code:

这也可以在原始代码中解决：

tgt.Range("A1:N" & (1+Last-Start)).Value = _
src.Range("A" & Start & ":N" & Last).Value