Option Explicit Const NUM = 11 '每列编号个数,可修改 Sub test() Dim arr, row, i, j, brr, n Application.ScreenUpdating = False With Sheets("sheet1") '源数据表名称 arr = .Range("a7:e" & .Cells(Rows.Count, "a").End(xlUp).row) End With With Sheets("sheet2") '输出数据表名称 .Cells.ClearContents For i = 1 To UBound(arr, 1) Step NUM ReDim brr(1 To 3, 1 To NUM) For j = i To i + NUM - 1 brr(1, j - i + 1) = arr(j, 5) brr(2, j - i + 1) = arr(j, 1) brr(3, j - i + 1) = arr(j, 3) If j = UBound(arr, 1) Then Exit For Next n = n + 4 Cells(n, "a").Resize(3) = Application.Transpose(Split("index号 编号 样品名称")) Cells(n, "b").Resize(3, UBound(brr, 2)) = brr Next End With Application.ScreenUpdating = True End Sub
Option Explicit Const NUM = 12 Sub test() Dim arr, i, j, brr, n Application.ScreenUpdating = False With Sheets("sheet1") arr = .Range("a10:e" & .Cells(Rows.Count, "a").End(xlUp).row) End With With Sheets("sheet2") .Cells.Clear For i = 1 To UBound(arr, 1) Step NUM ReDim brr(1 To 3, 1 To NUM) For j = i To i + NUM - 1 brr(1, j - i + 1) = arr(j, 5) brr(2, j - i + 1) = arr(j, 1) brr(3, j - i + 1) = arr(j, 3) If j = UBound(arr, 1) Then Exit For Next n = n + 4 With .Cells(n - 2, "a") .Resize(3) = Application.Transpose(Split("Index号 编号 样品名称")) .Resize(3, UBound(brr, 2) + 1).Borders.LineStyle = 1 End With .Cells(n - 2, "b").Resize(3, UBound(brr, 2)) = brr Next End With Application.ScreenUpdating = True End Sub