求助一行转3列，数据，

脚印0551

求助一行转3列，数据，具体效果详细看附件。表格里面有原格式数据，需要转换后格式。数据太多。只是做了3行的数据。所以求助大神帮忙写个vba 一次生成。减轻负担。谢谢。大神们

swl4561255

1. Private Sub CommandButton1_Click()
   
2. arr = Sheets("原格式").Range("A1").CurrentRegion
   
3. MsgBox arr(2, 5)
   
4. Dim brr(1 To 10000, 1 To 3)
   
5. For i = 2 To UBound(arr)
   
6.     For j = 2 To UBound(arr, 2) - 1 Step 2
   
7.         m = m + 1
   
8.         brr(m, 1) = arr(i, 1)
   
9.         brr(m, 2) = arr(i, j)
   
10.         brr(m, 3) = arr(i, j + 1)
    
11.     Next
    
12. Next
    
13. [A1].Resize(m, 3) = brr
    
14. End Sub

复制代码

longwin

附件供参考

limonet

关键字：union all

limonet

Sub limonet()
    Dim i%, Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=No';Data Source=" & ThisWorkbook.FullName
    For i = 2 To Range("BI2").Column Step 2
        StrSQL = StrSQL & " Union All Select F1,F" & i & ",F" & i + 1 & " From [原格式$A2:BI]"
    Next i
    Range("A1").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.28
   
2.     With Sheets("原格式")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         c = .UsedRange.Columns.Count
   
5.         arr = .[a1].Resize(r, c)
   
6.     End With
   
7.     ReDim brr(1 To 100000, 1 To 3)
   
8.     For i = 2 To UBound(arr)
   
9.         For j = 2 To UBound(arr, 2) Step 2
   
10.             If arr(i, j) <> Empty Then
    
11.                 m = m + 1
    
12.                 brr(m, 1) = arr(i, 1)
    
13.                 brr(m, 2) = arr(i, j)
    
14.                 brr(m, 3) = arr(i, j + 1)
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     With Sheets("转换后格式")
    
19.         .Cells.ClearContents
    
20.         .[a1].Resize(m, 3) = brr
    
21.     End With
    
22.     MsgBox "OK！"
    
23. End Sub
    

复制代码

沈默00

沈默00

好些天没写代码了，交个作业 ，
WPS用不了REDUCE ,不然函数也可以试试

quqiyuan

参与一下。。。