数据分列难题

netszzy

求助，附件想实现如下目的：数字变成单独一列，数字前面的中文文字变成这个数字的所在列的列头；
不一样的中文新建一列；一样的中文在同一列。


形如：
A1=甲：1乙：2
A2=乙：3丙：4
变成
A1=甲，B1=乙，C1=丙
A2=1，B2=2
C1=空，C2=3，C3=4

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     arr = Sheets("高消费").UsedRange
   
5.     a = 1
   
6.     r = 2
   
7.     With CreateObject("vbscript.regexp")
   
8.         .Pattern = "\d*\.?\d+"
   
9.         .Global = True
   
10.         For j = 2 To UBound(arr)
    
11.             brr = Split(arr(j, 1), ":")
    
12.             For i = 0 To UBound(brr) - 1
    
13.                 str1 = .Replace(brr(i), "")
    
14.                 If Len(str1) > 0 Then
    
15.                     If Not d.exists(str1) Then
    
16.                         Sheets("结果").Cells(1, a).Value = str1
    
17.                         d(str1) = a
    
18.                         a = a + 1
    
19.                     End If
    
20.                     c = d(str1)
    
21.                     Sheets("结果").Cells(WorksheetFunction.Max(Sheets("结果").Cells(Rows.Count, c).End(3).Row + 1, r), c) = Val(brr(i + 1))
    
22.                 End If
    
23.             Next i
    
24.             r = Sheets("结果").UsedRange.Rows.Count + 1
    
25.         Next j
    
26.         
    
27.     End With
    
28. 
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

liulang0808

模拟了一个结果，不知道是否能满足楼主需求，供参考

lsdongjh

1. Sub Test()
   
2.     Dim lngRows As Long, arr As Variant, lngRow As Long, lngCol As Long
   
3.     Dim objReg As Object, strTemp As String, strPat As String
   
4.     Dim objDic  As Object, objTitle As Object, lngID As Long
   
5.     Dim strTitle As String, strContent As String
   
6.     Dim objMatchs As Object, objMatch As Object
   
7. 
   
8.     Set objDic = CreateObject("Scripting.Dictionary")
   
9.     Set objTitle = CreateObject("Scripting.Dictionary")
   
10.    
    
11.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    
12.     arr = Sheet1.Range("A1:A" & lngRows)
    
13.    
    
14.     strPat = "([^:]*?):([\d.]*)"
    
15.     Set objReg = CreateObject("VBScript.RegExp")
    
16.     With objReg
    
17.         .Global = True
    
18.         .Pattern = strPat
    
19.     End With
    
20. 
    
21.     For lngRow = 2 To lngRows
    
22.         strTemp = arr(lngRow, 1)
    
23.         strTemp = Trim(strTemp)
    
24.         Set objMatchs = objReg.Execute(strTemp)
    
25.         For Each objMatch In objMatchs
    
26.             strTitle = objMatch.subMatches(0)
    
27.             strContent = objMatch.subMatches(1)
    
28.             objTitle(Trim(strTitle)) = ""
    
29.             strTitle = lngRow & "-" & Trim(strTitle)
    
30.             objDic(strTitle) = strContent
    
31.         Next
    
32.     Next
    
33.    
    
34.     lngRow = objTitle.Count
    
35.    
    
36.     Sheet1.Range("C1").Resize(1, lngRow) = objTitle.keys
    
37.    
    
38.     arr = Sheet1.Range("C1").Resize(lngRows, lngRow)
    
39.    
    
40.     For lngRow = 2 To lngRows
    
41.         For lngCol = 1 To UBound(arr, 2)
    
42.             strTemp = lngRow & "-" & arr(1, lngCol)
    
43.             arr(lngRow, lngCol) = objDic(strTemp)
    
44.         Next
    
45.     Next
    
46.    
    
47.     Sheet1.Range("C1").Resize(lngRows, UBound(arr, 2)) = arr
    
48. 
    
49. End Sub
    

复制代码

LMY123

正则表达式

netszzy

liulang0808 发表于 2018-6-25 14:32
模拟了一个结果，不知道是否能满足楼主需求，供参考

大神出手，不同寻常，非常感谢！

netszzy

liulang0808 发表于 2018-6-25 14:32
模拟了一个结果，不知道是否能满足楼主需求，供参考

大神，这个程序效率能否再提高？我有10万条数据，跑了几个小时了，一列还没好。

jiminyanyan

不要在循环里操作单元格。。。。

liulang0808

做了微调，看看是否有所改善吧

netszzy

liulang0808 发表于 2018-6-25 20:54
做了微调，看看是否有所改善吧

再请教一下，在数据量比较大的情况下，vba宏执行是csv格式效率高还是xlsx效率高，亦或是一样？