Question

在您说这是重复的内容之前，请先参阅下文。

TL：DR 在Sheet1上有一个包含数据的表，在Sheet2上有一个相似的表。

每张表上的表都有数据，其中一列是一个键，键具有与之关联的多个记录（如相同的邮政编码）。

我需要按id值（如邮政编码）将数据分成多个工作表，以便最终为每个id值创建一个单独的Excel文件，其中每个文件将有2个工作表。

Sheet1 将具有与相应的id值关联的源文件中Sheet1中的行。

Sheet2 将在源文件上具有Sheet2中具有相同ID值的行。

详细信息：

下面的宏按列值拆分行，其中“ D”列按相同的值（例如邮政编码）标识多个记录。

我需要的是能够为源文件上的多个工作表复制相同的子集和复制过程，例如Test1和Test2。目标是将每个工作表上的数据子集输出到多个文件中名称相似且格式设置相同的工作表中。

重要的是要保留所有格式，例如标题行上方的任何行（不从第1行开始），列宽和颜色，自动过滤器和图纸缩放。我相信，一旦找出进行分割的基本代码，我就能解决这个问题。

输出文件名称将包含ID值（例如邮政编码），后跟“ testfile.xlsx”。每个输出文件都有两个工作表，Test1和Test2。

每个工作表将复制结构，直到达到列标题为止，并按照相应的源工作表上的格式进行格式化，但将仅包含与id值相关联的行，该行将被拆分成给定文件。

现在仅假设两个工作表，Test1和Test2（一旦完成，我可以复制以添加更多的工作表）。还假设源文件上的两个工作表在键列D中都包含相同的ID值列表，但是与相同ID值相关联的行数在工作表中会有所不同。

最后，假设在Test1和Test2上的布局都相同，尽管实际上它们可能不同，例如Test1上的id列（D列）可能是Test2上的另一列（C列）。

正如我提到的，下面的代码完成单个工作表的工作。我需要复制此处理过程，以便它可用于多个工作表。我猜这是一个相对简单的调整，但可以使用一些帮助来弄清楚如何使其工作。

我有一个相似问题here，它复制了一些其他静态工作表。但是，不同之处在于，在这种情况下，还需要使用键值来拆分其他工作表。我是VBA的新手，因此需要明确的方法和带注释的代码示例。感谢您的帮助！

Sub parse_by_id()

Dim r As Long, rng As Range, ws As Worksheet
Dim lastRow As Integer

Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Sheets("Test1") 'Sheet1
    Sheets.Add().Name = "temp"
    .Range("D12", .Range("D" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("D12"), Unique:=True
     For Each rng In Sheets("temp").Range("D13", Sheets("temp").Range("D13").End(xlDown))
        .AutoFilterMode = False
        .Range("D12").AutoFilter field:=4, Criteria1:=rng 'field:=3
        Set ws = Sheets.Add

        lastRow = .Range("B12:F12").End(xlDown).Row 
        .Range("B12:bi" & lastRow).SpecialCells(xlCellTypeVisible).Copy 
        ws.Range("B12").PasteSpecial xlPasteColumnWidths
        ws.Range("B12").PasteSpecial xlPasteAll
        .Range("B2:bi11").Copy ws.Range("B2")   
        Columns("A:A").ColumnWidth = 1

        For r = 1 To lastRow
            ws.Rows(r).RowHeight = .Rows(r).RowHeight
        Next r

        ws.Range("B3:F3").MergeCells = True 
        ws.Name = rng
        ws.Move
        .AutoFilterMode = False
        Rows.Hidden = False
        Columns.Hidden = False
        ActiveWindow.DisplayGridlines = False
        Range("D13").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.Zoom = 95 
        ActiveWorkbook.Close SaveChanges:=True, Filename:="C:\TEMP\" & rng & "-testfile.xlsx"
    Next rng
      Sheets("temp").Delete
End With

VBA宏将数据拆分为多个工作表？

0 个答案: