excel多列合并到一列

云雾云绕

多列合并为一列：如何能快速的将样式一转化为样式二呢，谢谢各位老师~~

xiangbaoan

1. Sub test1()
   
2.   Dim Cnn As Object, SQL As String, ar, i As Byte
   
3.   Set Cnn = CreateObject("ADODB.Connection")
   
4.   If Application.Version < 12 Then
   
5.     Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
   
6.   Else
   
7.     Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
8.   End If
   
9.   Worksheets("Sheet1").Activate
   
10.   ar = Range("A1").CurrentRegion.Rows(2)
    
11.   For i = 2 To UBound(ar, 2)
    
12.     SQL = SQL & " UNION ALL SELECT " & ar(1, 1) & "," & ar(1, i) & ",'" & ar(1, i) & "' AS 部门 FROM [Sheet1$A2:D] WHERE LEN(编号)"
    
13.   Next
    
14.   Range("F2").CopyFromRecordset Cnn.Execute(Mid(SQL, 12))
    
15.   Cnn.Close
    
16.   Set Cnn = Nothing
    
17.   Beep
    
18. End Sub

复制代码

xiangbaoan

多列合并到一列.zip (15.84 KB, 下载次数: 17)

2022-1-8 13:40 上传

点击文件名下载附件

wang-way

1. Public Sub wang_way()
   
2.     'vx
   
3.     '日期  2022-01-08
   
4.     Dim Wb As Workbook
   
5.     Dim Sht As Worksheet
   
6.     Dim Rng As Range
   
7.     Dim arr, brr()
   
8.     Set Wb = Application.ThisWorkbook
   
9.     Set Sht = Wb.Worksheets(1)
   
10.     With Sht
    
11.         endrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         Set Rng = .Range("A2:D" & endrow)
    
13.         arr = Rng.Value
    
14.         ReDim brr(1 To (UBound(arr) - 1) * (UBound(arr, 2) - 1), 1 To 3)
    
15.         n = 0
    
16.         For i = 2 To UBound(arr)
    
17.             For j = 2 To UBound(arr, 2)
    
18.                 n = n + 1
    
19.                 brr(n, 1) = arr(i, 1)
    
20.                 brr(n, 2) = arr(i, j)
    
21.                 brr(n, 3) = arr(1, j)
    
22.             Next j
    
23.         Next i
    
24.                                        
    
25.         endcol = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
    
26.         Set Rng = .Cells(2, endcol)
    
27.         Rng.Resize(UBound(brr), UBound(brr, 2)).Value = brr
    
28.                                                      
    
29.     End With
    
30.                                     
    
31.     Set Wb = Nothing
    
32.     Set Sht = Nothing
    
33.     Set Rng = Nothing
    
34. 
    
35. End Sub
    

复制代码

云雾云绕

xiangbaoan 发表于 2022-1-8 13:37

谢谢您，非常感谢

云雾云绕

wang-way 发表于 2022-1-8 16:41

非常感谢！！！！

明天会更好zj

简单的代码

志南和尚

Sub t53()
    Dim arr, brr, i, j, k
    arr = Range("a2:d12")
    k = 0
    ReDim brr(1 To UBound(arr, 2) * UBound(arr), 1 To 3)
    For i = 2 To UBound(arr, 2)
        For j = 2 To UBound(arr)
        k = k + 1
           brr(k, 1) = arr(j, 1)
           brr(k, 2) = arr(j, i)
           brr(k, 3) = arr(1, i)
        Next
    Next
    Range("a15").Resize(UBound(brr), 3) = brr
End Sub

云雾云绕

明天会更好zj 发表于 2022-1-9 18:05
简单的代码

非常谢谢啦！