一个单元格内的多行数据进行数据汇总

zzxww

本来想着将单元格内多行数据每行分出来再汇总，但是由于数据量较大，且单元格内数据行不同，一直没成功希望老师们帮帮忙，谢谢啦！
例.zip (6.72 KB, 下载次数: 16)

2019-4-19 11:32 上传

点击文件名下载附件

小花鹿

西瓜呢，不要了？                                                                                                         

qingc0221

1.     Dim LastRow As Long, i As Long, j As Long
   
2.     Dim Regx As Object, m As Object
   
3.     Dim Str As String
   
4.     Dim Arr
   
5.    
   
6.     LastRow = Cells(Rows.Count, 1).End(xlUp).Row
   
7.     Arr = Array("苹果", "香蕉", "梨")
   
8.     Set Regx = CreateObject("VBScript.RegExp")
   
9.     For i = 2 To LastRow
   
10.         Str = Cells(i, 2)
    
11.         With Regx
    
12.             .Global = True
    
13.             For j = 0 To 2
    
14.                 .Pattern = "(\d+个) " & Arr(j)
    
15.                 If .test(Str) Then
    
16.                     Set m = .Execute(Str)
    
17.                     Cells(i, 8 + j) = m(0).submatches(0)
    
18.                 Else
    
19.                     Cells(i, 8 + j) = 0
    
20.                 End If
    
21.             Next j
    
22.         End With
    
23.     Next i
    
24. End Sub

复制代码

魂断蓝桥

返回结果

人员	苹果	菠萝	香蕉	西瓜	梨
A	10个	5个	2个	4个	1个
B	0	0	0	6个	5个
C	8个	0	12个	14个	0
D	14个	5个	2个	4个	3个

Option Explicit

'提前引用vbRichClient5控件，看我签名档下载并注册此控件
Sub b()
    Dim cnn As New cConnection
    Dim rs As New cRecordset
    Dim sql$, s, t, arr, I&, J&
    cnn.CreateNewDB
    sql = "CREATE TABLE T1(人员,件数,名称)"
    cnn.Execute sql
    arr = Sheet1.Range("A1").CurrentRegion
    cnn.BeginTrans
    For I = 2 To UBound(arr)
        s = Split(arr(I, 2), vbLf)
            For J = 0 To UBound(s)
                t = Split(s(J), " ")
                sql = "insert into T1 VALUES('" & arr(I, 1) & "','" & t(0) & "','" & t(1) & "')"
                cnn.Execute sql
            Next
    Next
    cnn.CommitTrans
[F:Z] = ""
s = ""
sql = "SELECT DISTINCT 名称 FROM T1"
rs.OpenRecordset sql, cnn
Do While Not rs.EOF
    s = s & "max(case when 名称='" & rs.Fields(0) & "' THEN 件数 ELSE 0 END ) AS " & rs.Fields(0) & ","
rs.MoveNext
Loop
s = Left(s, Len(s) - 1)
sql = "SELECT 人员," & s & " FROM T1 GROUP BY 人员"
rs.OpenRecordset sql, cnn
For I = 0 To rs.Fields.Count - 1
    Cells(1, 6 + I) = rs.Fields(I).Name
Next
Range("F2").CopyFromRecordset rs.GetADORsFromContent
    Set rs = Nothing
   Set cnn = Nothing
    'MsgBox Format(Timer - TIM, "0.00")
End Sub

swc3791

动作太慢，qingc0221已经给你回复了，我也刚弄好，给你做参考吧 分类汇总.zip (16.96 KB, 下载次数: 11)

2019-4-19 13:05 上传

点击文件名下载附件

zpy2

这种还是先不要合并单元格比较好统计

tigertc

1. Sub aa()
   
2. Dim arr, brr, crr, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. If [g1] <> "" Then [g1].CurrentRegion.Clear
   
5. arr = [a1].CurrentRegion
   
6. ReDim brr(1 To 3, 1 To 1)
   
7. For i = 2 To UBound(arr)
   
8.     s = Split(arr(i, 2), Chr(10))
   
9.     ReDim Preserve brr(1 To 3, 1 To UBound(brr, 2) + UBound(s) + 1)
   
10.     For j = 0 To UBound(s)
    
11.         ss = Split(s(j), " ")
    
12.         d(ss(1)) = 1
    
13.         n = n + 1
    
14.         brr(1, n + 1) = i
    
15.         brr(2, n + 1) = ss(0)
    
16.         brr(3, n + 1) = ss(1)
    
17.     Next j
    
18. Next i
    
19. ReDim crr(1 To UBound(arr), 1 To d.Count + 1)
    
20. k = d.keys: crr(1, 1) = "人员"
    
21. For i = 0 To UBound(k)
    
22.     crr(1, i + 2) = k(i)
    
23. Next
    
24. For i = 2 To UBound(brr, 2)
    
25.     For j = 2 To UBound(crr, 2)
    
26.         crr(brr(1, i), 1) = arr(brr(1, i), 1)
    
27.         If brr(3, i) = crr(1, j) Then crr(brr(1, i), j) = brr(2, i)
    
28.     Next j
    
29. Next i
    
30. For i = 2 To UBound(crr)
    
31.     For j = 2 To UBound(crr, 2)
    
32.         If crr(i, j) = "" Then crr(i, j) = 0
    
33.     Next j
    
34. Next i
    
35. [g1].Resize(UBound(crr), UBound(crr, 2)) = crr
    
36. End Sub

复制代码

tigertc

再多水果也不怕.....

shaokui123

各位高手学习了