数据分组的问题

杨小妹

附件 数据分组附件.rar (133.82 KB, 下载次数: 13)

2024-4-5 19:04 上传

点击文件名下载附件

谢谢老师！

swl4561255

1. Sub test()
   
2. ar = [A1].End(4).Row
   
3. For i = 1 To ar - 3
   
4. Range("A" & i & ":G" & i).Resize(4, 7).Copy Sheets("sheet2").[A1].Offset(5 * (i - 1), 0)
   
5. Next
   
6. End Sub

复制代码

shiruiqiang

蓝桥玄霜

分组的例子：

ooluckydog

Sub 数据分组()
    Dim i As Long, k As Long
    Dim maxRow As Long, maxCol As Long
    Dim d As Object
   
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To maxRow - 3
            d.Add i, .Cells(i, 1).Resize(4, maxCol).Value
        Next i
    End With
   
    With Sheet2
        For i = 1 To d.Count
            k = k + 1
            .Cells(k, 1).Resize(4, maxCol) = d(i)
            k = k + 4
        Next
    End With
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.5
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         arr = .[a1].Resize(r, 7)
   
5.     End With
   
6.     ReDim brr(1 To UBound(arr) * 10, 1 To 7)
   
7.     On Error Resume Next
   
8.     For i = 1 To UBound(arr) - 3
   
9.         For x = 1 To 4
   
10.             m = m + 1
    
11.             For j = 1 To UBound(arr, 2)
    
12.                 brr(m, j) = arr(i + x - 1, j)
    
13.             Next
    
14.         Next
    
15.         m = m + 1
    
16.     Next
    
17.     With Sheets("Sheet2")
    
18.         .[a1:h10000] = ""
    
19.         .[a1].Resize(m, 7) = brr
    
20.     End With
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码

cnmlgb9998

自从学了 PQ后，很多表格问题，解决很轻松，就一两句代码的事！ 比函数易懂！ 比VBA简单！

cnmlgb9998

用PQ不香？ 还要什么自行车。。。。。 PQ 中 最好用的 ACC函数，用处，真的大！

cnmlgb9998

楼上大佬们的VBA代码，要么是对单元格直接读写，这样效率会很差；要么用数组和字典，代码量又大。用PQ，直接在内存数组中运行，代码少，效率也高。