各位大神帮助小女子解决这个问题吧，头大了

mekemeke

前面发在了函数区，有大大说函数解决不了。。。让我发这里来，麻烦各位大神呢，帮帮偶吧~~
http://club.excelhome.net/thread-1383469-1-1.html

谢谢啦~~~

chxw68

详见附件。

jiangxiaoyun

example.zip (20.15 KB, 下载次数: 5)

2017-12-7 10:09 上传

点击文件名下载附件

abc123281

褚老师 有没有注意我昨天发在论坛上的那个汇总帖子，您看看能否实现

abc123281

老师  在这里
http://club.excelhome.net/thread-1383356-1-1.html

paciguard

1. Sub 按钮1_Click()
   
2. Dim ar, cc&
   
3. ReDim ar(1 To 4, 1 To 1)
   
4. cc = 1
   
5. For i = 1 To 4
   
6. Dim rng As Range, stra$, strb$, strc$, c&
   
7. stra = ""
   
8. strb = ""
   
9. strc = ""
   
10. Set rng = Range("A" & i).MergeArea
    
11. ReDim Preserve ar(1 To 4, 1 To cc)
    
12. ar(1, cc) = Range("A" & i).Text
    
13. k = 1
    
14. c = 0
    
15. For j = i To i + rng.Count - 1
    
16.    Do While k <= c + Val(Split(Split(Range("B" & j).Text, "@")(1), "(")(0))
    
17. If stra = "" Then
    
18. stra = "H" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(2)
    
19. strb = "W" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(1)
    
20. strc = "L" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(0)
    
21. Else
    
22. stra = stra & "," & "H" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(2)
    
23. strb = strb & "," & "W" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(1)
    
24. strc = strc & "," & "L" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(0)
    
25. End If
    
26.    k = k + 1
    
27.    Loop
    
28.    c = k - 1
    
29. Next j
    
30. ar(2, cc) = stra
    
31. ar(3, cc) = strb
    
32. ar(4, cc) = strc
    
33. i = i + rng.Count - 1
    
34. cc = cc + 1
    
35. Next i
    
36. Sheet1.Range("A" & 9).Resize(UBound(ar, 2), UBound(ar)) = Application.Transpose(ar)
    
37. End Sub
    

复制代码