求助VBA

深耕基层

求助VBA，谢谢！！！

3190496160

Sub 转置()
Dim ar As Variant
Dim br()
ar = Sheets("原数据").[a1].CurrentRegion
ReDim br(1 To 10000, 1 To 2)
For j = 1 To UBound(ar, 2)
    If ar(2, j) <> "" Then
        For i = 3 To UBound(ar)
            If Trim(ar(i, j)) <> "" Then
                n = n + 1
                br(n, 1) = ar(2, j)
                br(n, 2) = ar(i, j)
            End If
        Next i
    End If
Next j
With Sheets("结果数据")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, 2) = br
End With
MsgBox "ok!"
End Sub

3190496160

3190496160

求助vba.rar (14.65 KB, 下载次数: 6)

2023-2-15 14:44 上传

点击文件名下载附件

ykcbf1100

行列转换。

shiruiqiang

cjc209

Sub 测试()
    zdl = Sheet1.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    ReDim brr(1 To 99999, 1 To 2)
    For j = 1 To zdl
        zdh = Sheet1.Cells(100000, j).End(xlUp).Row
        For i = 3 To zdh
        k = k + 1
        brr(k, 1) = "'" & Sheet1.Cells(2, j)
        brr(k, 2) = "'" & Sheet1.Cells(i, j)
        Next
    Next
    Sheet2.[d2].Resize(k, 2) = brr
End Sub

2801959927

1. Option Explicit
   
2. Sub Main()
   
3.     Dim arr, brr()
   
4.     Dim i, j, tgt As Integer
   
5.     arr = Sheet1.Range("A1").CurrentRegion
   
6.     For i = 1 To UBound(arr, 2)
   
7.         For j = 1 To UBound(arr)
   
8.             If Len(arr(j, i)) > 0 Then
   
9.                 tgt = tgt + 1
   
10.                 ReDim Preserve brr(1 To 2, 1 To tgt)
    
11.                 If j = 1 Then
    
12.                     brr(1, tgt) = CStr(arr(j, i))
    
13.                     brr(2, tgt) = "/"
    
14.                 Else
    
15.                     brr(1, tgt) = CStr(brr(1, tgt - 1))
    
16.                     brr(2, tgt) = CStr(arr(j, i))
    
17.                 End If
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     Sheet3.UsedRange.ClearContents
    
22.     Sheet3.Range("A1").Resize(UBound(brr, 2), UBound(brr)) = WorksheetFunction.Transpose(brr)
    
23. End Sub

复制代码

2801959927

1. Option Explicit
   
2. Sub Main()
   
3.     Dim arr, brr()
   
4.     Dim i, j, tgt As Integer
   
5.     arr = Sheet1.Range("A1").CurrentRegion
   
6.     For i = 1 To UBound(arr, 2)
   
7.         For j = 1 To UBound(arr)
   
8.             If Len(arr(j, i)) > 0 Then
   
9.                 tgt = tgt + 1
   
10.                 ReDim Preserve brr(1 To 2, 1 To tgt)
    
11.                 If j = 1 Then
    
12.                     brr(1, tgt) = CStr(arr(j, i))
    
13.                     brr(2, tgt) = "/"
    
14.                 Else
    
15.                     brr(1, tgt) = CStr(brr(1, tgt - 1))
    
16.                     brr(2, tgt) = CStr(arr(j, i))
    
17.                 End If
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     Sheet3.UsedRange.ClearContents
    
22.     Sheet3.Range("A1").Resize(UBound(brr, 2), UBound(brr)) = WorksheetFunction.Transpose(brr)
    
23. End Sub

复制代码

2801959927

1. Option Explicit
   
2. Sub Main()
   
3.     Dim arr, brr()
   
4.     Dim i, j, tgt As Integer
   
5.     arr = Sheet1.Range("A1").CurrentRegion
   
6.     For i = 1 To UBound(arr, 2)
   
7.         For j = 1 To UBound(arr)
   
8.             If Len(arr(j, i)) > 0 Then
   
9.                 tgt = tgt + 1
   
10.                 ReDim Preserve brr(1 To 2, 1 To tgt)
    
11.                 If j = 1 Then
    
12.                     brr(1, tgt) = CStr(arr(j, i))
    
13.                     brr(2, tgt) = "/"
    
14.                 Else
    
15.                     brr(1, tgt) = CStr(brr(1, tgt - 1))
    
16.                     brr(2, tgt) = CStr(arr(j, i))
    
17.                 End If
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     Sheet3.UsedRange.ClearContents
    
22.     Sheet3.Range("A1").Resize(UBound(brr, 2), UBound(brr)) = WorksheetFunction.Transpose(brr)
    
23. End Sub

复制代码