Question

数据如下

我需要将这些数据分成两个级别

根据产品代码的第一个字母（C列）将数据划分为不同的工作簿，例如： A.xlsx，B.xlsx等，其中包含仅与这些字母相关的数据
根据唯一的产品代码将上述工作簿中的数据划分为工作表，例如： 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开头的工作表合并到一本工作簿中，并且＃34; A.xlsx＆＃34;对于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

VBA - 将文件拆分并优化为多个文件，并将这些文件拆分为多个文件

1 个答案: