一个客户多列信息转成一行

nifeng123

各位好，今天遇到一个问题，百度无法解决，请各位大神帮忙。
一个客户有多个电话，我需要是多个电话都在一列，我想把这些都转成行，求助，请查看附件，可能描述不清楚。
附件里面有我的数据源和我需要的格式。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:j" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Not d.exists(arr(i, 5)) Then
    
12.       ReDim brr(1 To 6)
    
13.       For j = 1 To 6
    
14.         brr(j) = arr(i, j)
    
15.       Next
    
16.     Else
    
17.       brr = d(arr(i, 5))
    
18.     End If
    
19.     n = UBound(brr)
    
20.     ReDim Preserve brr(1 To n + 4)
    
21.     For j = 7 To UBound(arr, 2)
    
22.       n = n + 1
    
23.       brr(n) = arr(i, j)
    
24.     Next
    
25.     d(arr(i, 5)) = brr
    
26.   Next
    
27.   With Worksheets("sheet2")
    
28.     .Cells.Clear
    
29.     .Range("a1:f1") = Array("机构", "model", "合同号", "有效合同", "客户名", "城市")
    
30.     m = 2
    
31.     mm = 0
    
32.     For Each aa In d.keys
    
33.       brr = d(aa)
    
34.       .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
35.       If mm < UBound(brr) Then
    
36.         mm = UBound(brr)
    
37.       End If
    
38.       m = m + 1
    
39.     Next
    
40.     n = 7
    
41.     For k = 1 To (mm - 6) / 4
    
42.       .Cells(1, n) = "电话" & k
    
43.       .Cells(1, n + 1) = "电话所属人" & k
    
44.       .Cells(1, n + 2) = "电话类型" & k
    
45.       .Cells(1, n + 3) = "与客户关系" & k
    
46.       n = n + 4
    
47.     Next
    
48.     With .Range("a1").Resize(m - 1, mm)
    
49.       .Borders.LineStyle = xlContinuous
    
50.       With .Font
    
51.         .Size = 8
    
52.       End With
    
53.     End With
    
54.     .Columns(1).Resize(, mm).AutoFit
    
55.   End With
    
56. End Sub
    

复制代码

chxw68

详见附件。

小花鹿

Sub test()
Dim d, d1, i&, ar, r&, j&, c&
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ar = [a1].CurrentRegion
For i = 2 To UBound(ar)
    If Not d.exists(ar(i, 5)) Then
        r = r + 1
        d(ar(i, 5)) = r
        For j = 1 To 10
            Cells(30 + r, j) = ar(i, j)
        Next j
        d1(ar(i, 5)) = 10
    Else
        c = d1(ar(i, 5))
        For j = 1 To 4
            Cells(30 + d(ar(i, 5)), c + j) = ar(i, 6 + j)
        Next j
        d1(ar(i, 5)) = d1(ar(i, 5)) + 4
    End If
Next i
End Sub

约定的童话

chxw68 发表于 2019-2-22 12:52

这个忒复杂了啊，学不来这个....

chxw68

约定的童话 发表于 2019-2-22 12:58
这个忒复杂了啊，学不来这个....

呵呵，其实挺简单的，你仔细琢磨下。

魂断蓝桥

我的表格.rar (20.27 KB, 下载次数: 9)

2019-2-22 13:33 上传

点击文件名下载附件

Option Explicit

Sub A()
Dim ARR, BRR(1 To 9, 1 To 50), I%, J%, M%, SQL$, S$, TMP
Dim CNN As New cConnection
Dim RS As New cRecordset
ARR = Sheet1.Range("A1").CurrentRegion
CNN.CreateNewDB
SQL = "CREATE TABLE A (机构,model,合同号,有效合同,客户名,城市,电话,电话所属人,电话类型,与客户关系)"
CNN.Execute SQL
CNN.BeginTrans
For I = 2 To UBound(ARR)
    S = ""
    For J = 1 To UBound(ARR, 2)
        S = S & "'" & ARR(I, J) & "',"
    Next
        S = Left(S, Len(S) - 1)
        SQL = "INSERT INTO A VALUES(" & S & ")"
        CNN.Execute SQL
Next
CNN.CommitTrans
SQL = "SELECT 机构,model,GROUP_CONCAT(DISTINCT(合同号)),有效合同,客户名,城市," _
             & "GROUP_CONCAT(电话||""|""||电话所属人||""|""||电话类型||""|""||与客户关系||""|"","""") AS T FROM A " _
            & "GROUP BY 机构,model,有效合同,客户名,城市 ORDER BY 客户名"
RS.OpenRecordset SQL, CNN
Do While Not RS.EOF
    M = M + 1
        For J = 0 To 5
            BRR(M, J + 1) = RS.Fields(J)
        Next
            TMP = Split(RS.Fields(6), "|")
                For I = 0 To UBound(TMP)
                    BRR(M, I + 7) = "'" & TMP(I)
                Next
    RS.MoveNext
Loop
Sheet2.Activate
[A2:AZ99] = ""
[A2].Resize(RS.RecordCount, 50) = BRR
Set RS = Nothing
Set CNN = Nothing
End Sub

duquancai

小花鹿 发表于 2019-2-22 12:55
Sub test()
Dim d, d1, i&, ar, r&, j&, c&
Set d = CreateObject("scripting.dictionary")

小花鹿 不出手则已，一出手就是精品。

小花鹿

duquancai 发表于 2019-2-22 13:36
小花鹿 不出手则已，一出手就是精品。

雕虫小技，消磨时间

carlostevez1984

小花鹿 发表于 2019-2-22 12:55
Sub test()
Dim d, d1, i&, ar, r&, j&, c&
Set d = CreateObject("scripting.dictionary")

烦请您赐教
For j = 1 To 10  这个10：意思是原始数据的10列吧
For j = 1 To 4   这个4：是客户名称前面的4列？
您这个字典用的真是太好了 太简洁了