将数据中的内容按模板输出

newlove

orr89 发表于 2020-11-4 11:24
Sub 排列()

    Sheet1.Activate

感谢你！辛苦你了！

orr89

newlove 发表于 2020-11-4 13:58
感谢你！辛苦你了！

Sub 排列()
   
    Sheet1.Activate
    Sheet1.Range("A2:H" & Sheet1.[a60000].End(xlUp).Row).Select
    With Sheet1.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("H2:H" & Sheet1.[a60000].End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=""
        End With
        .Header = xlNo
        .Orientation = xlSortColumns
        .MatchCase = False
        .SortMethod = xlPinYin
        .SetRange Rng:=Selection
        .Apply
    End With '辅助列乱序
   
    arr = Sheet1.Range("a1").CurrentRegion
   
    Sheet3.Activate
    With Sheet3
        .Cells.Clear
        lie = 1
        zu = 1
        hang = 2
        For 项目列 = 5 To 7
            If .Cells(.[b60000].End(xlUp).Row, "B") = "" Then
                .Cells(.[b60000].End(xlUp).Row, "A") = arr(2, 4)
                .Cells(.[b60000].End(xlUp).Row, "B") = arr(1, 项目列)
            Else
                .Cells(.[b60000].End(xlUp).Row + 2, "A") = arr(2, 4)
                .Cells(.[b60000].End(xlUp).Row + 2, "B") = arr(1, 项目列)
                hang = hang + 2
                zu = 1
                lie = 1
            End If
            For a = 2 To UBound(arr)
                If arr(a, 项目列) <> "" Then
                    lie = lie + 1
                    If lie = 8 Then
                        lie = 2
                        hang = hang + 3
                        zu = zu + 1
                    End If
                    .Cells(hang, 1) = zu & "组"
                    .Cells(hang, lie) = lie - 1 & "道"
                    .Cells(hang + 1, lie) = arr(a, 3)
                    .Cells(hang + 2, lie) = arr(a, 项目列)
                End If
            Next
            hang = .[b60000].End(xlUp).Row
            For 反查 = hang To 1 Step -3
                If Cells(反查 - 2, "E") <> "" Then
                    Exit For
                Else
                    For 反查1 = 5 To 2 Step -1
                        If Cells(反查 - 2, 反查1) <> "" Then
                            Exit For
                        Else
                            Range(Cells(反查 - 5, 反查1 + 2), Cells(反查 - 3, 反查1 + 2)).Copy
                            Cells(反查 - 2, 反查1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            Range(Cells(反查 - 5, 反查1 + 2), Cells(反查 - 3, 反查1 + 2)).ClearContents
                        End If
                    Next 反查1
                End If
            Next
        Next
    End With
   
End Sub '增加了每组必须大于3人的需求,仅供参考，自己修修改改吧.