单列数据按新标准重新分配至多列

15303194321

   

sheet1  是原数据，sheet2  是过程之一，sheet3 是目标样表，求VBA代码  谢谢

quqiyuan

数据源表没有区域ABCD，这个怎么分？

wang-way

quqiyuan 发表于 2024-6-17 17:31
数据源表没有区域ABCD，这个怎么分？

编号的首字母就是分区

15303194321

quqiyuan 发表于 2024-6-17 17:31
数据源表没有区域ABCD，这个怎么分？

型号的第一个字母 可以区分区域  忽略大小写

15303194321

quqiyuan 发表于 2024-6-17 17:31
数据源表没有区域ABCD，这个怎么分？

型号的首位字母  可以区分 区域  忽略大小写

quqiyuan

wang-way 发表于 2024-6-17 17:38
编号的首字母就是分区

没看出来呢，哈哈，好笨

quqiyuan

15303194321 发表于 2024-6-17 17:39
型号的首位字母  可以区分 区域  忽略大小写

没看出来呢，哈哈，好笨

15303194321

quqiyuan 发表于 2024-6-17 17:41
没看出来呢，哈哈，好笨

quqiyuan

15303194321 发表于 2024-6-17 17:47

明白，刚开始时候没看出来。。。

wang-way

1. Sub main()
   
2.     ' 设置wb为当前工作簿
   
3.     Set wb = Application.ThisWorkbook
   
4.     '' 设置sht为指定名称的工作表，引号内填写工作表名称
   
5.     Set sht = wb.Worksheets("原数据")
   
6.     ' 设置psht为工作表，在引号内填写工作表名称
   
7.     Set psht = wb.Worksheets("目标表样")
   
8.     ' 设置范围为A2单元格
   
9.     Set rng = psht.Range("A2")
   
10.     ' 获取工作簿的完整路径，赋值给fp
    
11.     fp = wb.FullName
    
12.     SQL = "SELECT 品名,型号,left(型号,1) as 区域 From [" & sht.Name & "$a1:b]"
    
13.     SQL = " transform first(型号) select 品名 from(" & SQL & ") group by 品名,型号 pivot 区域"
    
14.     Debug.Print SQL
    
15.     SqlToRng fp, SQL, rng
    
16. End Sub
    
17. ' 过程结束
    
18. '' 代码功能：根据SQL语句查询结果 输出到目标单元格区域
    
19. '' 参数说明
    
20. '' 参数【Datapath 】：工作簿的文件路径
    
21. '' 参数【     SQL    】：SQL查询语句
    
22. '' 参数【     Rng    】：目标单元格区域
    
23. '' 调用示范：SqlToRng fp,sql,rng
    
24. Sub SqlToRng(ByVal DataPath As String, ByVal SQL As String, ByVal rng As Range)
    
25.     'Debug.Print SQL
    
26.     '' 判断工作簿路径是否存在，若不存在弹窗提示，退出函数
    
27.     If Len(DataPath) = 0 Or Len(Dir(DataPath)) = 0 Then
    
28.         MsgBox "数据源地址为空或者数据源文件不存在！", vbInformation, "QQ84857038"
    
29.         '' 退出
    
30.         Exit Sub
    
31.     End If
    
32.     '' 判断SQL语句是否为空
    
33.     If Len(SQL) = 0 Then
    
34.         MsgBox "SQL语句不能为空！", vbInformation, "QQ84857038"
    
35.         '' 退出
    
36.         Exit Sub
    
37.     End If
    
38.     '' 声明连接器变量cnn，结果集变量rs，引擎字符串变量dataEngine
    
39.     Dim CNN, rs, dataEngine  As String
    
40.     '' 判断Excel版本，选择相应的引擎
    
41.     Select Case Application.Version * 1
    
42.     Case Is <= 11
    
43.         dataEngine = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
    
44.     Case Is >= 12
    
45.         dataEngine = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
    
46.     End Select
    
47.     '' 创建ADO Connection 连接器
    
48.     Set CNN = CreateObject("ADODB.Connection")
    
49.     '' 打开数据源
    
50.     CNN.Open dataEngine & DataPath
    
51.     '' 执行查询，返回记录集
    
52.     Set rs = CNN.Execute(SQL)
    
53.     '' 把数据集转置为一个数组
    
54.     If Not (rs.EOF And rs.BOF) Then
    
55.         rng.CopyFromRecordset rs
    
56.     End If
    
57.     '' 关闭记录集
    
58.     rs.Close
    
59.     '' 关闭连接器
    
60.     CNN.Close
    
61.     '' 释放对象
    
62.     Set rs = Nothing
    
63.     Set CNN = Nothing
    
64. End Sub
    

复制代码