VBA - Для того, чтобы разделить и преуспевать файл на несколько файлов и разделить эти файлы на несколько листов

Question

Данные выглядит следующим образом

Мне нужно разделить эти данные на двух уровнях

1. Разделите данные на разные книги на основе первой буквы кода продукта (столбец C), например A.xlsx, B.xlsx и т. Д., Которые будут содержать данные, относящиеся только к этим письмам

2. Разделите данные в указанных выше книгах на рабочие листы на основе уникального кода продукта, например. C.xlsx будет иметь листы с именем C02, C021, и эти листы будут содержать данные, относящиеся к коду procut.

Как их можно объединить в одном коде 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