选择性粘贴中转置问题

xinzijin2006

问题是：需要把行内容转置到列。如2行中的内容转置到A列，2行中的个数不定，但是如2行中有14个，A列就有13个空格。然后到下一个需要转置的行。

请各位帮忙，谢谢！

ykcbf1100

附件供参考，为了让代码更有通用性，结果放在表2。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.26
   
2.     arr = Sheets("Sheet1").UsedRange
   
3.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
4.     ReDim zrr(1 To 10000, 1 To UBound(arr, 2))
   
5.     For i = 2 To UBound(arr)
   
6.         If arr(i, 1) <> Empty Then
   
7.             m = m + 1
   
8.             For j = 1 To UBound(arr, 2)
   
9.                 brr(m, j) = arr(i, j)
   
10.             Next
    
11.         End If
    
12.     Next
    
13.     For x = 1 To m
    
14.         n = n + 1
    
15.         For j = 1 To UBound(brr, 2)
    
16.             zrr(n, j) = brr(x, j)
    
17.         Next
    
18.         For j = 2 To UBound(brr, 2)
    
19.             If brr(x, j) <> Empty Then
    
20.                 n = n + 1
    
21.                 zrr(n, 1) = brr(x, j)
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     With Sheets("Sheet2")
    
26.         .UsedRange.Offset(1).ClearContents
    
27.         .[a2].Resize(n, UBound(arr, 2)) = zrr
    
28.     End With
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br(), i&, j&, r&, iRowSize&, iColSize&
   
    ar = [R2].Resize(10 ^ 3, 10 ^ 3).Value
    For i = 1 To UBound(ar)
        If Len(ar(i, 1)) = False Then
            r = r + 1
            ReDim Preserve br(1 To r)
            br(r) = i
        End If
    Next i
   
    r = 0
    For i = 1 To UBound(ar)
        For j = 2 To UBound(ar, 2)
            If Len(ar(i, j)) Then
                r = r + 1
                ar(br(r), 1) = ar(i, j)
                iRowSize = br(r)
            Else
                If j - 1 > iColSize Then iColSize = j - 1
                Exit For
            End If
        Next j
    Next i
   
    [A2].Resize(iRowSize, iColSize) = ar
    Beep
End Sub

gwjkkkkk

...........