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

newlove

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

orr89

Sub 排列()

    Dim d
    Set d = CreateObject("Scripting.Dictionary")
   
    arr = Sheet1.Range("a1").CurrentRegion
   
    For a = 2 To UBound(arr)
        If arr(a, 4) <> "" Then
            If Not d.exists(arr(a, 1)) Then
                d(arr(a, 1)) = a
            Else
                d(arr(a, 1)) = d(arr(a, 1)) & "/" & a
            End If
        End If
    Next
    items = d.items
   
    lie = 1
    zu = 1
    hang = 2
    For a = 0 To UBound(items)
        hang1 = Split(items(a), "/")
        For b = 0 To UBound(hang1)
            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(hang1(b), 2)
            Cells(hang + 2, lie) = arr(hang1(b), 4)
        Next
    Next a
   
End Sub
仅供参考,陆红豪和你的排序有差异,看不懂你是咋排的.

newlove

我重新传一份，麻烦你了
这个表就是学生参加运动会的分组分道的表，例如：将参加100米的运动员分成几组，每组6人，每组里根据原有数据里内容显示班级和运动员名字！这只是一个项目！

orr89

newlove 发表于 2020-11-3 08:52
我重新传一份，麻烦你了
这个表就是学生参加运动会的分组分道的表，例如：将参加100米的运动员分成几组， ...

Sub 排列()

    Sheet1.Activate
    Sheet1.Range("A2:D" & Sheet1.[a60000].End(xlUp).Row).Select
    With Sheet1.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("D2:D" & 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
   
    With Sheet4
        lie = 1
        zu = 1
        hang = 2
        For a = 2 To UBound(arr)
            If arr(a, 3) <> "" 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, 2)
                .Cells(hang + 2, lie) = arr(a, 3)
            End If
        Next a
    End With
   
End Sub仅供参考，自己修修改改吧

newlove

前面没有说清楚 ，现重新发一份，请老师们帮帮！

是关于运动会报名分项分组分道的  编程。

newlove

orr89 发表于 2020-11-2 12:31
Sub 排列()

    Dim d

感谢你的帮助！

newlove

orr89 发表于 2020-11-3 10:30
Sub 排列()

    Sheet1.Activate

感谢你！单项分组分道成功排列！如果要再增加几个单项，如何循环了？

orr89

newlove 发表于 2020-11-4 08:46
感谢你！单项分组分道成功排列！如果要再增加几个单项，如何循环了？

先乱序排，然后在把同一项目的排在一起，然后用字典记录每一个项目的起始行和终止行不就可以循环了

newlove

orr89 发表于 2020-11-4 09:03
先乱序排，然后在把同一项目的排在一起，然后用字典记录每一个项目的起始行和终止行不就可以循环了

我不会了，请老师帮帮设计 下！麻烦了！具体表格我发上来，请老师看看该如何设计！

orr89

newlove 发表于 2020-11-4 09:19
我不会了，请老师帮帮设计 下！麻烦了！具体表格我发上来，请老师看看该如何设计！

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 + 5
                   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
        Next
    End With
   
End Sub '仅供参考，自己修修改改吧，每一次需求和表都不一样，去淘宝找个代工吧。