工作表2的原始資料標題也被拉入統計(arr = Range("a2:g" & [a1048576].End(xlUp).Row)有調整)，工作表3排序方式5大欄( ElseIf i Mod 5 = 0 Then 有調整)，排序是直排如圖，能再調整嗎，感謝

問答區主要是技術交流
這個回答已經把你需要的東西都寫上去了
最後的修改最好是自己來
單純請人寫的話建議走發包的流程

PS. 之前的問題會有人直接寫好，是因為問題的性質不同，並不是說這邊原本就會直接幫人寫好的喔

解決方法大約這樣吧,如沒任何 vba 基礎,我給什麼對你也沒有什麼好處

了解，我只是想主題能有完整語法呈現，作為技術範本，也謝謝兩位大師的建議

大家交流一下吧,我自己也不是猛,參考一下

Sub test()

    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("a2:g" & [a1048576].End(xlUp).Row)
    For i = 1 To UBound(arr)
        If WorksheetFunction.Trim(Cells(i, "a")) <> "" Then
            d(arr(i, 1)) = d(arr(i, 1)) + 1
        End If
    Next
    k = d.keys
    t = d.items
    
    [c1].Resize(1, 2) = Array("型號", "重覆次數")
    [c2].Resize(d.Count, 1) = Application.Transpose(k)
    [d2].Resize(d.Count, 1) = Application.Transpose(t)
    
    row_count = WorksheetFunction.RoundUp((UBound(k) + 1) / 5, 0)
    remind_no = UBound(k) + 1
    
    y = 1
    x = 4
    j = 5
    i = 0
    Do
        If i = 0 Then
            x = x + 2
        ElseIf record_no Mod row_count = 0 Then
            y = 1
            x = x + 2
            j = j - 1
            remind_no = remind_no - record_no
            row_count = WorksheetFunction.RoundUp(remind_no / j, 0)
            record_no = 0
        Else
            y = y + 2
        End If
        Cells(y, x) = "型號"
        Cells(y, x + 1) = "重覆次數"
        Cells(y + 1, x) = k(i)
        Cells(y + 1, x + 1) = t(i)
        i = i + 1
        record_no = record_no + 1
    Loop Until i = UBound(k) + 1
    

End Sub

借花獻佛，玩一下...
也希望版主的目的是技術交流，而不是來要程式碼的

Private Sub CommandButton1_Click()
    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("a2:g" & [a1048576].End(xlUp).Row)
    For i = 1 To UBound(arr)
        '排除型號空白
        If WorksheetFunction.Trim(arr(i, 1)) <> "" Then
            d(arr(i, 1)) = d(arr(i, 1)) + 1
        End If
    Next
    k = d.keys
    t = d.items
    
    [c1].Resize(1, 2) = Array("型號", "重覆次數")
    [c2].Resize(d.Count, 1) = Application.Transpose(k)
    [d2].Resize(d.Count, 1) = Application.Transpose(t)

   '排序
    Columns("C:D").Select
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add Key:=Range("C2:C" & d.Count + 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("工作表1").Sort
        .SetRange Range("C1:D" & d.Count + 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Y = 3
    X = 7
    j = 5
    i = 0
    record_no = 0
    
    remind_no = UBound(k) + 1
    row_count = WorksheetFunction.RoundUp(remind_no / j, 0)
    
    Worksheets("工作表1").Activate
    Worksheets("工作表1").Cells(1, X + 2) = "商品目錄表"
    Worksheets("工作表1").Range(Worksheets("工作表1").Cells(1, X + 2), Worksheets("工作表1").Cells(1, X + 2 + (j * 2) - 1)).Select
    With Selection
      .HorizontalAlignment = xlCenterAcrossSelection '跨欄置中
      '填滿的顏色: 36 : 淺黃色
      .Interior.ColorIndex = 36
    End With

    Do
        If i = 0 Then
            X = X + 2
        ElseIf record_no Mod row_count = 0 Then
            Y = 3
            X = X + 2
            j = j - 1
            remind_no = remind_no - record_no
            row_count = WorksheetFunction.RoundUp(remind_no / j, 0)
            record_no = 0
        Else
            Y = Y + 1
        End If
        
        If Y = 3 Then
          Cells(2, X) = "型號"
          Cells(2, X + 1) = "重覆次數"
        End If
        
        Cells(Y, X) = Cells(i + 2, 3)
        Cells(Y, X + 1) = Cells(i + 2, 3 + 1)
        i = i + 1
        record_no = record_no + 1
    Loop Until i = UBound(k) + 1

End Sub