☰

创建多列排序，并在不同项目之间添加一条线

tag-icon • tag-icon microsoft-excel vba
创建多列排序，并在不同项目之间添加一条线

因此，我开始对材料清单进行排序，我可以按照自己的意愿输入材料（见此处）在此处输入图片描述 然后它将按正确的方式排序，如下所示。

我有一个“让魔法发生 v2”按钮可以自动将列表按我想要的方式排序，但我想添加一个新行（仍然使用框和公式格式化）如下所示：在此处输入图片描述

这是我当前的代码，但我不知道如何在不同的材料/尺寸之间添加“空白”线：

Private Sub Let_The_Magic_Happen_v2_Click()
Application.ScreenUpdating = False
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("J35:J" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "HRT,LASER,DELRIN,HDPE,8#XLPE", DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("L35:L" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("M35:M" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("N35:N" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("O35:O" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= xlSortNormal
    With ActiveWorkbook.Worksheets("Quote_and_Cut").Sort
        .SetRange Range("A35:W" & Cells(Rows.Count, "J").END(xlUp).Row)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Application.ScreenUpdating = True
End Sub

我感谢您提供的任何帮助，谢谢！

答案1

我认为我已经找到了一个很好的解决方案，如下面的代码所示：本质上，我所做的就是检查材料类型列并检查该行和下一行中是否有任何内容，如果有，我会检查它们是否彼此相等并增加我的计数器。如果它们不相等，那么我知道它们一定是不同的材料，因此，我在它们之间添加了一个空格。我还在这里进行了检查，以确保两种材料之间没有空格，这样它就不会重复更多不需要的空格。

' Version Number: v2.1.1

Private Sub Let_The_Magic_Happen_v2_Click()
Application.ScreenUpdating = False
'Sorts the worksheet
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("J35:J" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
    "HRT,HRTRND,HRA,HRCNL,HRRND,HRFLT,HRSHT,CFRND,CFFLT,ALT,ALTRND,ALA,ALCNL,ALRND,ALFLT,SSRND,SSA,SSFLT,SSSHT,LASER,DELRIN,NYLON,HDPE,UMHW,8#XLPE,MISC", DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("L35:L" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("M35:M" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("N35:N" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("O35:O" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Quote_and_Cut").Sort
    .SetRange Range("A35:W" & Cells(Rows.Count, "J").End(xlUp).Row)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'Removes the extra rows at the end of the cut sheet, as they are not needed (but leave two extra rows at the bottom for looks)
Dim Lastrow1 As Long
Lastrow = ActiveSheet.Cells(Rows.Count, "J").End(xlUp).Row
Rng = "J35:J" & Lastrow
Lastrow1 = Lastrow - Excel.WorksheetFunction.CountBlank(ActiveSheet.Range(Rng))
Dim EndOfCut As Range
    With Range("U1:U32000")
        Set EndOfCut = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not EndOfCut Is Nothing Then
            Cell_Add = Split(EndOfCut.Address, "$")
            ThisRow = Cell_Add(1)
            ThisCol = Cell_Add(2)
            If ((ThisCol - 1) - (Lastrow1 + 1)) > 3 Then
                Rows((Lastrow1 + 3) & ":" & (ThisCol - 1)).EntireRow.Delete
            End If
        Else
            msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
        End If
    End With

'Scrolls through the list and inserts a line between different materials
With Range("J35").Select
    Dim counter As long
    counter = 35
    mtlname = "a"
    mtlname2 = "a"
    Dim EndCount As long
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd0:
    mtlname = "a"
    mtlname2 = "a"
    Do While (mtlname = mtlname2)
        If counter >= EndCount Then 
            GoTo hardEnd0
        Else
            mtlname = Cells(counter, 10)
            counter = counter + 1
            mtlname2 = Cells(counter, 10)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If mtlname2 = "" Then
            counter = counter + 1
            GoTo softEnd0
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
hardEnd0:
Loop


'Scrolls through the list and inserts a line between different DIM1
With Range("L35").Select
    counter = 35
    dim1name = "0"
    dim1name2 = "0"
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd1:
    dim1name = "0"
    dim1name2 = "0"
    Do While (dim1name = dim1name2)
        If counter >= EndCount Then 
            GoTo hardEnd1
        Else
            dim1name = Cells(counter, 12)
            counter = counter + 1
            dim1name2 = Cells(counter, 12)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
            counter = counter + 1
            GoTo softEnd1
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
Loop
hardEnd1:  
End With

'Scrolls through the list and inserts a line between different DIM2
With Range("M35").Select
    counter = 35
    dim2name = "0"
    dim2name2 = "0"
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd2:
    dim2name = "0"
    dim2name2 = "0"
    Do While (dim2name = dim2name2)
        If counter >= EndCount Then 
            GoTo hardEnd2
        Else
            dim2name = Cells(counter, 13)
            counter = counter + 1
            dim2name2 = Cells(counter, 13)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
            counter = counter + 1
            GoTo softEnd2
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
Loop
hardEnd2:  
End With

'Scrolls through the list and inserts a line between different DIM3
With Range("N35").Select
    counter = 35
    dim3name = "0"
    dim3name2 = "0"
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd3:
    dim3name = "0"
    dim3name2 = "0"
    Do While (dim3name = dim3name2)
        If counter >= EndCount Then 
            GoTo hardEnd3
        Else
            dim3name = Cells(counter, 14)
            counter = counter + 1
            dim3name2 = Cells(counter, 14)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
            counter = counter + 1
            GoTo softEnd3
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
Loop
hardEnd3:  
End With

'Fixes the Cut List Subtotal SUM, because Excel tries to change it during sort
Dim ThisPos As Range
    With Range("U1:U32000")
        Set ThisPos = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not ThisPos Is Nothing Then
            Cell_Add = Split(ThisPos.Address, "$")
            ThisRow = Cell_Add(1)
            ThisCol = Cell_Add(2)
            ActiveWorkbook.Worksheets("Quote_and_Cut").Range("W" & ThisCol).Value = "=SUM(W35:W" & (ThisCol - 1) & ")"
        Else
            msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
        End If
    End With
Application.ScreenUpdating = True
End With
End Sub

相关内容