求助VBA写法

ykcbf1100

13602822168 发表于 2024-6-28 15:31
已重新上传了。谢谢！！

改好了。。。

我把数据紧靠左上角了，这样便于数据定位。

ykcbf1100

其实就是加个列循环。

1. Sub ykcbf()  '//2024.6.28
   
2.     c = Range("a1").End(2).Column
   
3.     ActiveSheet.UsedRange.Offset(1, c + 1).ClearContents
   
4.     arr = [a1].CurrentRegion
   
5.     For j = 1 To c
   
6.         r = Cells(Rows.Count, j).End(3).Row
   
7.         For i = 5 To r
   
8.             st = ""
   
9.             For x = i - 4 To i
   
10.                 st = st & Cells(x, j)
    
11.             Next
    
12.             Cells(i, c + 2 + j) = st
    
13.         Next
    
14.     Next
    
15.     MsgBox "OK！"
    
16. End Sub
    
17. 
    

复制代码

saghj

13602822168

ykcbf1100 发表于 2024-6-28 15:56
改好了。。。

我把数据紧靠左上角了，这样便于数据定位。

能否不靠左角，因为前面还有很多数据？？

ykcbf1100

13602822168 发表于 2024-6-28 16:35
能否不靠左角，因为前面还有很多数据？？

改一下吧。。。

ykcbf1100

小改一下。。。

1. Sub ykcbf()  '//2024.6.28
   
2.     c = Range("g1").End(2).Column
   
3.     ActiveSheet.UsedRange.Offset(, c + 1).ClearContents
   
4.     arr = [a1].CurrentRegion
   
5.     For j = 7 To c
   
6.         r = Cells(Rows.Count, j).End(3).Row
   
7.         For i = 5 To r
   
8.             st = ""
   
9.             For x = i - 4 To i
   
10.                 st = st & Cells(x, j)
    
11.             Next
    
12.             Cells(i, c - 4 + j) = st
    
13.         Next
    
14.     Next
    
15.     MsgBox "OK！"
    
16. End Sub
    
17. 
    

复制代码

跨越时空

micch

为什么都是每次都循环5个数字合并呢。实际上不需要循环啊，开始合并5个数字后，每次都去掉一个补一个就行了嘛

跨越时空

micch 发表于 2024-6-28 18:00
为什么都是每次都循环5个数字合并呢。实际上不需要循环啊，开始合并5个数字后，每次都去掉一个补一个就行了 ...

回复的人多，各有各的思路，样式多多益善

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&, k&
   
    ar = [G1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
    For j = 1 To UBound(ar, 2)
        For i = 5 To UBound(ar)
            If Len(ar(i, j)) Then
                ReDim cr(0 To 4)
                For k = 0 To UBound(cr)
                    cr(k) = ar(i - 4 + k, j)
                Next k
            Else
                Exit For
            End If
            br(i, j) = Join(cr, "")
        Next i
    Next j
   
    [U1].Resize(UBound(br), UBound(br, 2)) = br
    Beep
End Sub