[已解决]请大师完善下代码，实现附件的要求，谢谢！

cyb412204170

请大师完善下代码，实现附件的要求，谢谢！



求助20120708.rar (36.55 KB, 下载次数: 18)

2012-7-8 14:39 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-7-8 15:08

1. Sub 房号汇总()
   
2.     Dim Ar1, Arr11(), i%, D, M
   
3.     Dim SD As Date
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     SD = Range("b1")
   
6. 
   
7.     Ar1 = Sheets("记录表").[a1].CurrentRegion
   
8.     For i = 2 To UBound(Ar1)
   
9.         If Ar1(i, 1) = SD Then
   
10.             If D.exists(Ar1(i, 2)) Then
    
11.                 Arr11(2, D(Ar1(i, 2))) = Arr11(2, D(Ar1(i, 2))) + Ar1(i, 6)
    
12.                 If Ar1(i, 4) <> "" Then Arr11(3, D(Ar1(i, 2))) = Ar1(i, 4)    '加这句
    
13.             Else
    
14.                 M = M + 1
    
15.                 ReDim Preserve Arr11(1 To 3, 1 To M)   '这句原来的2改成3
    
16.                 D(Ar1(i, 2)) = M
    
17.                 Arr11(1, M) = Ar1(i, 2)
    
18.                 Arr11(2, M) = Ar1(i, 6)
    
19.                 If Ar1(i, 4) <> "" Then Arr11(3, M) = Ar1(i, 4)    '加这句
    
20.             End If
    
21.         End If
    
22.     Next
    
23. 
    
24.     Range("a3:c65536").ClearContents 'b改成c
    
25.     [a3].Resize(UBound(Arr11, 2), UBound(Arr11)) = Application.Transpose(Arr11)
    
26. End Sub

复制代码

跳转到最佳答案楼层

hrpotter

1. Sub 房号汇总()
   
2.     Dim Ar1, Arr11(), i%, D, M
   
3.     Dim SD As Date
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     SD = Range("b1")
   
6. 
   
7.     Ar1 = Sheets("记录表").[a1].CurrentRegion
   
8.     For i = 2 To UBound(Ar1)
   
9.         If Ar1(i, 1) = SD Then
   
10.             If D.exists(Ar1(i, 2)) Then
    
11.                 Arr11(2, D(Ar1(i, 2))) = Arr11(2, D(Ar1(i, 2))) + Ar1(i, 6)
    
12.                 If Ar1(i, 4) <> "" Then Arr11(3, D(Ar1(i, 2))) = Ar1(i, 4)    '加这句
    
13.             Else
    
14.                 M = M + 1
    
15.                 ReDim Preserve Arr11(1 To 3, 1 To M)   '这句原来的2改成3
    
16.                 D(Ar1(i, 2)) = M
    
17.                 Arr11(1, M) = Ar1(i, 2)
    
18.                 Arr11(2, M) = Ar1(i, 6)
    
19.                 If Ar1(i, 4) <> "" Then Arr11(3, M) = Ar1(i, 4)    '加这句
    
20.             End If
    
21.         End If
    
22.     Next
    
23. 
    
24.     Range("a3:c65536").ClearContents 'b改成c
    
25.     [a3].Resize(UBound(Arr11, 2), UBound(Arr11)) = Application.Transpose(Arr11)
    
26. End Sub

复制代码

cyb412204170

hrpotter 发表于 2012-7-8 15:08

你好，结帐单号07-03-008中同一房号有两个服务员，如何才能全部显示？
也就是以后同一房号超过一个服务员的要全部显示，格式为“张三，李四“，谢谢！

hrpotter

cyb412204170 发表于 2012-7-9 12:48
你好，结帐单号07-03-008中同一房号有两个服务员，如何才能全部显示？
也就是以后同一房号超过一个服务员 ...

试试这个

1. Sub 房号汇总()
   
2.     Dim Ar1, Arr11(), i%, D, M
   
3.     Dim SD As Date
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     SD = Range("b1")
   
6. 
   
7.     Ar1 = Sheets("记录表").[a1].CurrentRegion
   
8.     For i = 2 To UBound(Ar1)
   
9.         If Ar1(i, 1) = SD Then
   
10.             If D.exists(Ar1(i, 2)) Then
    
11.                 Arr11(2, D(Ar1(i, 2))) = Arr11(2, D(Ar1(i, 2))) + Ar1(i, 6)
    
12.                 If Ar1(i, 4) <> "" Then
    
13.                     If Arr11(3, D(Ar1(i, 2))) = "" Then
    
14.                         Arr11(3, D(Ar1(i, 2))) = Ar1(i, 4)
    
15.                     Else
    
16.                         Arr11(3, D(Ar1(i, 2))) = Arr11(3, D(Ar1(i, 2))) & "," & Ar1(i, 4)
    
17.                     End If
    
18.                 End If
    
19.             Else
    
20.                 M = M + 1
    
21.                 ReDim Preserve Arr11(1 To 3, 1 To M)   '这句原来的2改成3
    
22.                 D(Ar1(i, 2)) = M
    
23.                 Arr11(1, M) = Ar1(i, 2)
    
24.                 Arr11(2, M) = Ar1(i, 6)
    
25.                 If Ar1(i, 4) <> "" Then Arr11(3, M) = Ar1(i, 4)    '加这句
    
26.             End If
    
27.         End If
    
28.     Next
    
29. 
    
30.     Range("a3:c65536").ClearContents    'b改成c
    
31.     [a3].Resize(UBound(Arr11, 2), UBound(Arr11)) = Application.Transpose(Arr11)
    
32. End Sub

复制代码

ztccsj

高手如云，深不可测

cyb412204170

hrpotter 发表于 2012-7-9 12:59
试试这个

谢谢，搞定了。