使用Sheep1

Question

I有一个代码，该代码从Sheep1（来自程序的导出）中获取数据，并创建一个结合所有相同零件号并将数量添加在一起的汇总。我现在想创建一个附加功能，该功能将项目与PRTCOL中的唯一标识符分开，并将每个项目都放在自己的选项卡上，并带有随附的信息，例如该项目下面的所有零件。有一个级别标识符，其中“ 2”是要分开的项目。

我正在探讨的问题是，在第二级项目中的某些项目中，还有一个需要完整的项目，该项目需要将其标识为3级，并且这些零件被确定为4级。因此，理想情况下，它将破坏2级项目，然后进一步分解3级项目。现在，棘手的部分是，我只想分解以1tdxxx开头的零件，因为这象征着一个要完成的项目，该项目内部有其他部分而不是任何值。

Sub ROLLUP()
    Dim LASTROW As Long, ROWMULT As Long, BASEQTY As Long, LASTROWROLL As Long, PRTQTY As Long, LEVELS As Long, LASTCOL As Long
    Dim PRT As String, LEVLET As String, DESC As String, UOM As String, MADEFROM As String, GEOCOL As Long, PTYPE As String, GEOM As String
    Dim PRTCOL As Integer, QTYCOL As Integer, LEVELCOL As Integer, MADECOL As Integer, DESCCOL As Integer, UOMCOL As Integer, TYPECOL As Integer
    Dim CAGECOL As Integer, CAGE As String, DWGNUM As String
    Dim REXIST As Boolean, PRTEXIST As Boolean
    Dim LEVELARRAY() As Long
    Dim i As Long, j As Long, CURLEV As Long, NEXTLEV As Long
    Dim DWGCOL As Integer

    PRTCOL = 1
    QTYCOL = 1
    LEVELCOL = 1
    MADECOL = 1
    DESCCOL = 1
    UOMCOL = 1
    TYPECOL = 1
    GEOCOL = 1
    CAGECOL = 1
    DWGCOL = 1
    DWGNUM = ""

    With ActiveWorkbook
        LASTROW = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        LASTCOL = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        REXIST = False
        PRTEXIST = False

        ' Setting column values to pull data from
        With .Sheets("Sheet1")
            For i = 1 To LASTCOL
                If InStr(1, .Cells(1, i), "ID", vbTextCompare) Then PRTCOL = i
                If InStr(1, .Cells(1, i), "Quantity", vbTextCompare) Then QTYCOL = i
                If InStr(1, .Cells(1, i), "Level", vbTextCompare) Then LEVELCOL = i
                If InStr(1, .Cells(1, i), "Made", vbTextCompare) Then MADECOL = i
                If InStr(1, .Cells(1, i), "Name", vbTextCompare) Then DESCCOL = i
                If InStr(1, .Cells(1, i), "Unit", vbTextCompare) Then UOMCOL = i
                If InStr(1, .Cells(1, i), "Type", vbTextCompare) Then TYPECOL = i
                If InStr(1, .Cells(1, i), "GEOMETRY", vbTextCompare) Then GEOCOL = i
                If InStr(1, .Cells(1, i), "CAGE", vbTextCompare) Then CAGECOL = i
            Next i
        End With

        LEVLET = Split(Cells(1, LEVELCOL).Address, "$")(1)
        LEVELMAX = Application.WorksheetFunction.Max(Range(LEVLET & "1:" & LEVLET & LASTROW))
        LEVELMIN = Application.WorksheetFunction.Min(Range(LEVLET & "1:" & LEVLET & LASTROW))
        CURLEV = LEVELMIN
        LEVELS = LEVELMAX - LEVELMIN + 1
        ReDim LEVELARRAY(LEVELS)

        ' Setting level multipliers to 1
        For i = 1 To LEVELS
            LEVELARRAY(i) = 1
        Next i

        ' Code to create a rollup sheet if it doesn't exist
        For i = 1 To .Sheets.Count
            If .Sheets(i).Name = "Rollup" Then
                REXIST = True
                Exit For
            End If
        Next i
        If REXIST = False Then
            .Sheets.Add.Name = "Rollup"
            With .Sheets("Rollup")
                .Columns("A").NumberFormat = "@"
                .Cells(1, 1) = "PART NUMBER"
                .Cells(1, 2) = "DESCRIPTION"
                .Cells(1, 3) = "ORDER QUANTITY"
                .Cells(1, 4) = "UNIT OF MEASURE"
                .Cells(1, 5) = "MADE FROM"
                .Cells(1, 6) = "PART TYPE"
                .Cells(1, 7) = "GEOMETRY"
                .Cells(1, 8) = "CAGE CODE"
                .Cells(1, 9) = "DRAWING NUMBER"
                .Range("A:Z").AutoFilter
            End With
        End If

        ActiveWorkbook.Sheets("Sheet1").Activate
        With ActiveSheet
            For i = 2 To LASTROW
                CURLEV = .Cells(i, LEVELCOL)
                PRT = .Cells(i, PRTCOL)
                DESC = .Cells(i, DESCCOL)
                UOM = .Cells(i, UOMCOL)
                MADEFROM = .Cells(i, MADECOL)
                PTYPE = .Cells(i, TYPECOL)
                GEOM = .Cells(i, GEOCOL)
                CAGE = .Cells(i, CAGECOL)
                DWGNUM = ""

                If .Cells(i, QTYCOL) = "" Or .Cells(i, QTYCOL) <= 0 Then
                    ROWMULT = 1
                    BASEQTY = 1
                    PRTQTY = BASEQTY
                Else
                    ROWMULT = .Cells(i, QTYCOL)
                    BASEQTY = .Cells(i, QTYCOL)
                    PRTQTY = BASEQTY
                End If

                LEVELARRAY(.Cells(i, LEVELCOL).Value) = ROWMULT

                If CURLEV > LEVELMIN Then
                    For j = i To 2 Step -1
                        If .Cells(j, LEVELCOL) = LEVELMIN Then
                            If .Cells(j, QTYCOL) > 0 Then
                                LEVELARRAY(.Cells(j, LEVELCOL)) = .Cells(j, QTYCOL)
                            Else
                                LEVELARRAY(.Cells(j, LEVELCOL)) = 1
                            End If
                            Exit For
                        End If
                    Next j

                    For j = LBound(LEVELARRAY) To UBound(LEVELARRAY)
                        If j <> CURLEV Then
                            PRTQTY = PRTQTY * LEVELARRAY(j)
                        End If
                    Next j
                End If

                ActiveWorkbook.Sheets("Rollup").Activate
                With ActiveSheet
                    LASTROWROLL = .Cells(Rows.Count, 1).End(xlUp).Row
                    For j = 2 To LASTROWROLL
                        If .Cells(j, 1) = PRT Then
                            PRTEXIST = True
                            .Cells(j, 3) = .Cells(j, 3) + PRTQTY
                            Exit For
                        End If
                    Next j
                    If PRTEXIST = False Then
                        .Cells(LASTROWROLL + 1, 1) = PRT
                        .Cells(LASTROWROLL + 1, 2) = DESC
                        .Cells(LASTROWROLL + 1, 3) = PRTQTY
                        .Cells(LASTROWROLL + 1, 4) = UOM
                        .Cells(LASTROWROLL + 1, 5) = MADEFROM
                        .Cells(LASTROWROLL + 1, 6) = PTYPE
                        .Cells(LASTROWROLL + 1, 7) = GEOM
                        .Cells(LASTROWROLL + 1, 8) = CAGE
                        .Cells(LASTROWROLL + 1, 9) = DWGNUM
                    End If
                End With
                PRTEXIST = False
            Next i
        End With
    End With

    ' New function to create individual tabs for level 2 items
    CreateLevel2Tabs
End Sub

Sub CreateLevel2Tabs()
    Dim ws As Worksheet
    Dim level2Sheet As Worksheet
    Dim LASTROW As Long
    Dim i As Long
    Dim PRT As String
    Dim level2Items As Collection
    Set level2Items = New Collection

    Set ws = ThisWorkbook.Sheets("Rollup")
    LASTROW = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Collect level 2 items
    For i = 2 To LASTROW
        If ws.Cells(i, 3).Value = 2 Then ' Assuming column 3 is the level column
            PRT = ws.Cells(i, 1).Value
            On Error Resume Next
            level2Items.Add PRT, CStr(PRT) ' Use PRT as key to avoid duplicates
            On Error GoTo 0
        End If
    Next i

    ' Create individual tabs for each level 2 item
    For Each PRT In level2Items
        On Error Resume Next
        Set level2Sheet = ThisWorkbook.Sheets(PRT)
        If level2Sheet Is Nothing Then
            Set level2Sheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            level2Sheet.Name = PRT
        End If
        On Error GoTo 0

        ' Copy relevant data to the new sheet
        ws.Rows(1).Copy Destination:=level2Sheet.Rows(1) ' Copy headers
        For i = 2 To LASTROW
            If ws.Cells(i, 1).Value = PRT Then
                ws.Rows(i).Copy Destination:=level2Sheet.Rows(level2Sheet.Cells(level2Sheet.Rows.Count, 1).End(xlUp).Row + 1)
            End If
        Next i
    Next PRT
End Sub

我试图尝试，但我确实没有任何技能，因此大多数是复制/粘贴，而不是目前尝试学习。这会让我成为办公室周围的人。 请首先提供一些示例数据，并很乐意为您进行一些测试

Answer 1