從一個源工作表創建多個工作表或工作簿

Question

我有一個包含1000多行的電子表格。唯一標識符是位於列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 

UPDATE t o在評論中回答問題

如果源系列只有一行，則粘貼的結果將不正確。這可以通過粘貼到一個細胞來解決，所以

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