Question

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

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

我想构建一个足够灵活的代码，我可以在其中修改它以在工作簿中创建多个工作表（带或不带标题），或者让它足够灵活，我可以修改它以根据每个供应商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

Answer 1

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

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

为：

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

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

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

更新以回答评论中的问题

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

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

变为

tgt.Range("A1").PasteSpecial xlPasteAll

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

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

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

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

1 个答案: