求助！

LQF2017

如要实现附件的功能，以下代码怎么改啊，望各位大神不吝赐教！

Sub test()     With Sheets("1")         r = .Cells(Rows.Count, 1).End(3).Row         ReDim brr(1 To r \ 7 + 1, 1 To 7)         arr = .[a1].Resize(r)         n = 1         For i = 1 To r             m = i Mod 7             If m Then                 brr(n, m) = arr(i, 1)             Else                 n = n + 1             End If         Next     End With     With Sheets("2")         .UsedRange.ClearContents         .[a1].Resize(n, 6) = brr     End With End Sub

LQF2017

以上代码也是论坛的大神給的，就是复制的内容不规则的话就乱了

yjh_27

LQF2017 发表于 2020-1-1 21:17
以上代码也是论坛的大神給的，就是复制的内容不规则的话就乱了

1. Sub test()
   
2.     With Sheets("1")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         ReDim brr(1 To r, 1 To 20)
   
5.         arr = .[a1].Resize(r)
   
6.         n = 1
   
7.         For i = 1 To r
   
8.             If arr(i, 1) = "" Then
   
9.                 n = n + 1
   
10.                 m = 0
    
11.             Else
    
12.                 m = m + 1
    
13.                 brr(n, m) = arr(i, 1)
    
14.             End If
    
15.         Next
    
16.     End With
    
17.     With Sheets("2")
    
18.         .UsedRange.ClearContents
    
19.         .[a1].Resize(n, 20) = brr
    
20.     End With
    
21. End Sub
    

复制代码

LQF2017

问题已解决，万分感谢！-*

Yalishanda30

LQF2017 发表于 2020-1-2 20:42
问题已解决，万分感谢！-*

论坛标准感谢方式，右下角评分送花