[已解决]如何增加一个条件选择VBA程序，谁来完善我的VBA程序，谢谢哥哥姐姐们了。。

wangjiayu_1985

我有个VBA程序是提取文件里的内容进行汇总，如附件，提取原文件,我想给这个汇总加个条件选择，满足条件，发放美金，没有满足条件的发人民币
这个文件的内容是，我有40个人工作（name1。。。），分成4组[40People Grouping]下面的IDNUM对应的内容，两组12人的对应下面IDNUM
，1,2，两组8人的对应的是下面的IDNUM，3,4。我想给12人一组的发放美金，其余的发人民币。
我这个VBA没有美金和人民币之分，所以我想加个条件选择，我想以钱的种类做区分，每种钱里有多少人，我自己的VBA里没有给钱加单位，
,条件选择是通过[40People Grouping]下的分组来发放钱的单位，12人的发美金，其余发人民币。
希望大神给出代码，谢谢了。小弟跪谢了。。。求求你们了。。。

现在的形式

我想要的形式

分组

附件.rar (12.79 KB, 下载次数: 4)

2015-9-4 10:00 上传

点击文件名下载附件
原文件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-8 11:12

1. Sub tt()
   
2.     MsgBox "选择文件!"
   
3.     filename1 = Application.GetOpenFilename("All Files(*.*),*.*")
   
4.     If filename1 <> False Then
   
5.         Temp = Split(filename1, "")
   
6.         Sfile1 = Temp(UBound(Temp))
   
7.     Else
   
8.         MsgBox "No PT Program is Selected!"
   
9.         Exit Sub
   
10.     End If
    
11.    
    
12.   '################################################################################
    
13.     Dim arr(1 To 1000, 1 To 1)      '把原文件读入数组arr
    
14.     fnum1 = FreeFile
    
15.     Open filename1 For Input As #fnum1
    
16.     Do While Not EOF(fnum1)
    
17.     n = n + 1
    
18.         Line Input #1, arr(n, 1)   '读入每行
    
19.     Loop
    
20.     Close #fnum1
    
21. '################################################################################
    
22.    
    
23.     Set d = CreateObject("scripting.dictionary")
    
24.     Set dd = CreateObject("scripting.dictionary")
    
25.     For i = 1 To n
    
26.         If InStr(arr(i, 1), "Group") > 0 Then Exit For
    
27.     Next
    
28.    
    
29.     For k = i + 2 To n       '姓名和币种挂钩
    
30.         kk = kk + 1
    
31.         bz = IIf(kk <= 2, "美元", "人民币")
    
32.         xrr = Split(arr(k, 1), " ")
    
33.         For j = 2 To UBound(xrr)
    
34.             xname = Trim(xrr(j))
    
35.             d(xname) = bz
    
36.         Next
    
37.     Next
    
38.    
    
39.     For k = 3 To i - 1
    
40.         xrr = Split(arr(k, 1), " ")
    
41.         xname = xrr(1): je = xrr(2)     '姓名，金额
    
42.         bz = d(xname)
    
43.         xkey = je & bz    '金额+币种为key
    
44.         dd(xkey) = dd(xkey) + 1
    
45.     Next
    
46. '################################################################################
    
47.     ActiveSheet.Cells.ClearContents       '显示结果
    
48.     [a1].Resize(n, 1) = arr
    
49.     Range("f1") = "钱的种类"
    
50.     Range("g1") = "人数"
    
51.     [f2].Resize(dd.Count, 2) = Application.Transpose(Array(dd.keys, dd.items))
    
52.    
    
53. End Sub
    
54. 
    
55. 
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     MsgBox "选择文件!"
   
3.     filename1 = Application.GetOpenFilename("All Files(*.*),*.*")
   
4.     If filename1 <> False Then
   
5.         Temp = Split(filename1, "")
   
6.         Sfile1 = Temp(UBound(Temp))
   
7.     Else
   
8.         MsgBox "No PT Program is Selected!"
   
9.         Exit Sub
   
10.     End If
    
11.    
    
12.   '################################################################################
    
13.     Dim arr(1 To 1000, 1 To 1)      '把原文件读入数组arr
    
14.     fnum1 = FreeFile
    
15.     Open filename1 For Input As #fnum1
    
16.     Do While Not EOF(fnum1)
    
17.     n = n + 1
    
18.         Line Input #1, arr(n, 1)   '读入每行
    
19.     Loop
    
20.     Close #fnum1
    
21. '################################################################################
    
22.    
    
23.     Set d = CreateObject("scripting.dictionary")
    
24.     Set dd = CreateObject("scripting.dictionary")
    
25.     For i = 1 To n
    
26.         If InStr(arr(i, 1), "Group") > 0 Then Exit For
    
27.     Next
    
28.    
    
29.     For k = i + 2 To n       '姓名和币种挂钩
    
30.         kk = kk + 1
    
31.         bz = IIf(kk <= 2, "美元", "人民币")
    
32.         xrr = Split(arr(k, 1), " ")
    
33.         For j = 2 To UBound(xrr)
    
34.             xname = Trim(xrr(j))
    
35.             d(xname) = bz
    
36.         Next
    
37.     Next
    
38.    
    
39.     For k = 3 To i - 1
    
40.         xrr = Split(arr(k, 1), " ")
    
41.         xname = xrr(1): je = xrr(2)     '姓名，金额
    
42.         bz = d(xname)
    
43.         xkey = je & bz    '金额+币种为key
    
44.         dd(xkey) = dd(xkey) + 1
    
45.     Next
    
46. '################################################################################
    
47.     ActiveSheet.Cells.ClearContents       '显示结果
    
48.     [a1].Resize(n, 1) = arr
    
49.     Range("f1") = "钱的种类"
    
50.     Range("g1") = "人数"
    
51.     [f2].Resize(dd.Count, 2) = Application.Transpose(Array(dd.keys, dd.items))
    
52.    
    
53. End Sub
    
54. 
    
55. 
    

复制代码

grf1973

选择文件用的原代码，其他小改了一下。

wangjiayu_1985

grf1973 发表于 2015-9-8 11:13
选择文件用的原代码，其他小改了一下。

啥也不想说了 ，你就是一个牛逼的人，小弟佩服了，发了好多天了，也没有人解答，我本来都放弃了的，今天没事进来看看，结果你给我了一个惊喜，谢谢了，谢了，非常感谢，你有微信吗，可以加你的微信吗。125082173，这是我的微信，很想认识你。

wangjiayu_1985

grf1973 发表于 2015-9-8 11:13
选择文件用的原代码，其他小改了一下。

大神哥哥，谢谢你，能不能再请教一下，如果我的人数增加了一组12人的，如附件里的原文件，我导入进去了还是显示人民币，请问这个能实现吗，就是说我的人数和分组不固定的情况下，如何自动区分，钱的种类呢，麻烦你了，
fujian.rar (19.31 KB, 下载次数: 2)

2015-9-10 23:25 上传

点击文件名下载附件

grf1973

有点小难度。现在的做法是查看下面的分组人数，超过8个为美元，否则为人民币。而判断是否人名的依据只能是把非数值型的认为是人名。试试看吧。

wangjiayu_1985

grf1973 发表于 2015-9-11 10:33
有点小难度。现在的做法是查看下面的分组人数，超过8个为美元，否则为人民币。而判断是否人名的依据只能是把 ...

你好我是wangjiayu_1985 聊过QQ的
你这次这个完全解答了我现在的问题，谢谢，
但是现在有个问题，我最原始的文件不是这个样子的，我只是想通过这个形式问，别人能看的明白一点，我以前用最原始文件问，没人回答，所以我就这么问了，我最原始的人名是数字，如附件，（最原始文件里的最后两项，）我以为数字改成人名都异曲同工的，可是我弄不来，希望你能帮我在改改，如果弄不了就算了，但是还是谢谢你的。
PTchengshi.rar (54.07 KB, 下载次数: 2)

2015-9-11 22:39 上传

点击文件名下载附件

grf1973

选择“整理后提问的文件”

wangjiayu_1985

grf1973 发表于 2015-9-12 09:53
选择“整理后提问的文件”

不好意思麻烦你了，请问这次你给我的这个文件，没有人民币了，如图，13,14.。。到21组，都不是12人一组的，想发人民币，是不是分组代码需要改改，不知道能不能实现，这个麻烦你好几次了，真不好意思了，在帮忙看看谢谢了。。。

grf1973

改了一下。