VBA - 要拆分和Excel文件分成多個文件，並將這些文件分割成多張

Question

的數據如下

我需要通過兩級

1. 來劃分這個數據根據產品代碼的第一個字母（C列）將數據分成不同的工作簿A.xlsx，B.xlsx等將包含僅與這些字母有關的數據

2. 根據唯一產品代碼將上述工作簿中的數據分成工作表，例如， C.xlsx將具有名爲C02，C021的工作表，這些工作表將包含與修正代碼有關的數據。

如何將這兩個組合在一個VBA代碼中？

我有下面的代碼將數據分割成產品代碼表：

    Sub split_data() 
    Dim lr As Long 
    Dim ws As Worksheet 
    Dim vcol, i As Integer 
    Dim icol As Long 
    Dim myarr As Variant 
    Dim title As String 
    Dim titlerow As Integer 
    vcol = 3 
    Set ws = Sheets("Sales Data") 
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
    title = "A1:H1" 
    titlerow = ws.Range(title).Cells(1).Row 
    icol = ws.Columns.Count 
    ws.Cells(1, icol) = "Unique" 
    For i = 2 To lr 
    On Error Resume Next 
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then 
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
    End If 
    Next 
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 
    ws.Columns(icol).Clear 
    For i = 2 To UBound(myarr) 
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
    Else 
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
    End If 
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
    Sheets(myarr(i) & "").Columns.AutoFit 
    Next 
    ws.AutoFilterMode = False 
    ws.Activate
 

End Sub 
 

但現在我需要所有的表與一個聯合啓動進入工作簿「 A.xlsx「並且類似於B，C和D.在此需要幫助

Answer 1

試試這個。您需要更改文件路徑和可能的工作表參考

Sub x() 

Dim rCell As Range, r1 As Range, r2 As Range 
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet 

Application.DisplayAlerts = False 
Application.ScreenUpdating = False 

With ThisWorkbook.Sheets("Sheet1") 
    Set r2 = .Range("A1").CurrentRegion 
    .Cells(1, r2.Columns.Count + 1) = "First" 
    .Cells(2, r2.Columns.Count + 1).Resize(r2.Rows.Count - 1).Formula = "=LEFT(C2,1)" 
    Sheets.Add().Name = "temp" 
    r2.Columns(r2.Columns.Count + 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True 
    For Each rCell In Sheets("temp").Range("A2", Sheets("temp").Range("A" & Rows.Count).End(xlUp)) 
     .AutoFilterMode = False 
     .Range("A1").AutoFilter field:=r2.Columns.Count + 1, Criteria1:=rCell 
     Set ws1 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
     .AutoFilter.Range.Copy ws1.Range("A1") 
     ws1.Copy 
     Set wb = ActiveWorkbook 
     With wb 
      .Sheets.Add(After:=wb.Sheets(1)).Name = "Temp" 
      .Sheets(1).Range("C1", .Sheets(1).Range("C" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Sheets("Temp").Range("A1"), Unique:=True 
      For Each r1 In .Sheets("Temp").Range("A2", .Sheets("Temp").Range("A" & Rows.Count).End(xlUp)) 
       .Sheets(1).Range("A1").AutoFilter field:=3, Criteria1:=r1 
       Set ws2 = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) 
       .Sheets(1).AutoFilter.Range.Copy ws2.Range("A1") 
       ws2.Name = r1 
       .Sheets(1).ShowAllData 
      Next r1 
      .Sheets("Temp").Delete 
      .Sheets(1).Delete 
      .Close SaveChanges:=True, Filename:="C:\" & rCell & ".xlsx" 
     End With 
    Next rCell 
    .AutoFilterMode = False 
    Sheets("temp").Delete 
End With 

Application.DisplayAlerts = True 

End Sub