格式转换，求老师们设计个代码。数据量比较大

mushan1104

老师们，求一个代码。
就是把第一张图的数据内容转换到第二张图的格式内容。每张表有50个客户。感谢。

图1

图2

limonet

关键字：union all

limonet

Sub limonet()
    Dim i%, j%, L%, S$, 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
    i = Sheet1.Cells(3, Columns.Count).End(xlToLeft).Column
    For j = 3 To i Step 5
        L = L + 1
        S = "F" & Replace(Join(Application.Transpose(Sheet1.Range(Sheet1.Cells(j + 3, "B"), Sheet1.Cells(j + 7, "B")))), " ", ",F")
        StrSQL = StrSQL & " Union All Select '" & L & "','" & Sheet1.Cells(2, j + 1) & "','" & Sheet1.Cells(2, j + 4) & "',F2," & S & " From [汇总表$A4:AA]"
    Next j
    Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

mushan1104

limonet 发表于 2024-8-2 11:51
Sub limonet()
    Dim i%, j%, L%, S$, Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Conne ...

感谢大佬帮助！！！
再求助您一个问题。规格那一列变成汉字的话，代码运行不了。请教原因，感谢！

limonet

Sub limonet()
    Dim i%, j%, k%, L%, S$, 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
    i = Sheet1.Cells(3, Columns.Count).End(xlToLeft).Column
    For j = 3 To i Step 5
        L = L + 1: S = ""
        For k = j To j + 4
            S = S & ",F" & k
        Next k
        StrSQL = StrSQL & " Union All Select '" & L & "','" & Sheet1.Cells(2, j + 1) & "','" & Sheet1.Cells(2, j + 4) & "',F2" & S & " From [汇总表$A4:AA]"
    Next j
    Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

kyxfyzg

Sub test()
Dim arr, brr
arr = Sheets("汇总表").Range("a1").CurrentRegion
n = (UBound(arr) - 3) * ((UBound(arr, 2) - 2) / 5)
ReDim brr(1 To n, 1 To 9)
For i = 3 To UBound(arr, 2) Step 5
    k = k + 1
    For j = 4 To UBound(arr)
        h = h + 1
        brr(h, 1) = k
        brr(h, 2) = arr(2, i + 1)
        brr(h, 3) = arr(2, i + 4)
        brr(h, 4) = arr(j, 2)
        brr(h, 5) = arr(j, i)
        brr(h, 6) = arr(j, i + 1)
        brr(h, 7) = arr(j, i + 2)
        brr(h, 8) = arr(j, i + 3)
        brr(h, 9) = arr(j, i + 4)
    Next j
Next i
With Sheets("汇总表2")
.Range("a1").CurrentRegion.Clear
.Range("a1") = "序号"
.Range("b1") = "客户名称"
.Range("c1") = "编号"
.Range("d1") = "规格"
For i = 3 To 7
.Cells(1, i + 2) = Sheets("汇总表").Cells(3, i)
Next i
.Range("a2").Resize(UBound(brr), 9) = brr
End With
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.2
   
2.     With Sheets("汇总表")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         bt = .Columns(1).Find("序号", LookIn:=xlValues).Row
   
5.         c = .Cells(bt, "XFD").End(1).Column
   
6.         arr = .[a1].Resize(r, c)
   
7.     End With
   
8.     ReDim brr(1 To 10000, 1 To 9)
   
9.     For j = 3 To UBound(arr, 2) Step 5
   
10.         For i = bt + 2 To UBound(arr)
    
11.             m = m + 1
    
12.             brr(m, 1) = arr(i, 1)
    
13.             brr(m, 2) = arr(bt, j + 1)
    
14.             brr(m, 3) = arr(bt, j + 4)
    
15.             brr(m, 4) = arr(i, 2)
    
16.             For x = 1 To 5
    
17.                 brr(m, x + 4) = arr(i, j + x - 1)
    
18.             Next
    
19.         Next
    
20.     Next
    
21.     With Sheets("汇总表2")
    
22.         .UsedRange.Offset(1).Clear
    
23.         With .[a2].Resize(m, 9)
    
24.             .Value = brr
    
25.             .Borders.LineStyle = 1
    
26.             .HorizontalAlignment = xlCenter
    
27.             .VerticalAlignment = xlCenter
    
28.         End With
    
29.     End With
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

飞天篮球猪