求一代码，请见附件，谢谢！！！

dzsrmyh

  AAA工作簿名称是固定不变的，里面工作表每月增加一张，格式也是固定不变，每张工作表的人员和金额是不固定的，有时人多，有时人少，金额也是不固定的。文件夹还有很多其他的文件
要求：BBB工作簿里面的人员信息除了包含AAA工作簿里面的人员外还有很多其他人员，如何通过VBA代码实现减去指定AAA工作表相同人员的金额（比如黄色单元格人员萧义伟所对应的金额8888.88元减去AAA工作表3同一人员对应的金额6.66元，就应该是8882.22元，以此类推。）

shiruiqiang

目前按照要求，减去第一张表格的金额

dzsrmyh

shiruiqiang 发表于 2023-3-1 18:33
目前按照要求，减去第一张表格的金额

谢谢您的回复，代码应该还有点问题：AAA工作簿中有三张表（分别有111、109、103人）运行代码后有105人金额有变化？？？我的要求是先弹出AAA工作簿由我指定减去某张工作表对应的金额

shiruiqiang

这3个地方自己加一下代码

dzsrmyh

shiruiqiang 发表于 2023-3-1 19:10
这3个地方自己加一下代码

你好，非常感谢，现在还有一点问题，就是在文件夹中除了这两个文件外，还有很多文件，可否在下面代码中添加代码指定该文件夹中的某一文件

Sub test()
Dim f, fso, dic
Set dic = CreateObject("scripting.dictionary")
Set fso = CreateObject("scripting.filesystemobject")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, ThisWorkbook.Name) = 0 Then
            With Workbooks.Open(f)
                brr = .Sheets(1).UsedRange
                .Close False
            End With
            For j = 7 To UBound(brr)
                dic(brr(j, 3)) = brr(j, 7)
            Next j
        End If
    Next f
    arr = Sheets(1).UsedRange
    For x = 4 To UBound(arr)
    If dic.exists(arr(x, 3)) Then
    arr(x, 4) = Val(arr(x, 4)) - dic(arr(x, 3))
    End If
    Next
    Sheets(1).UsedRange = arr
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

dzsrmyh

shiruiqiang 发表于 2023-3-1 19:10
这3个地方自己加一下代码

您好，非常感谢，现在还有一点问题，就是该文件夹中除了这两个文件外，还有很多其他文件，如何在下面代码中添加代码指定其中的AAA这个文件（AAA是我虚拟的文件名）

1. Sub test()
   
2. Dim f, fso, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set fso = CreateObject("scripting.filesystemobject")
   
5. 
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8. 
   
9.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
10.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.             With Workbooks.Open(f)
    
12.                 brr = .Sheets(1).UsedRange
    
13.                 .Close False
    
14.             End With
    
15.             For j = 7 To UBound(brr)
    
16.                 dic(brr(j, 3)) = brr(j, 7)
    
17.             Next j
    
18.         End If
    
19.     Next f
    
20.     arr = Sheets(1).UsedRange
    
21.     For x = 4 To UBound(arr)
    
22.     If dic.exists(arr(x, 3)) Then
    
23.     arr(x, 4) = Val(arr(x, 4)) - dic(arr(x, 3))
    
24.     End If
    
25.     Next
    
26.     Sheets(1).UsedRange = arr
    
27.     Application.DisplayAlerts = True
    
28.     Application.ScreenUpdating = True
    
29. End Sub

复制代码

dzsrmyh

shiruiqiang 发表于 2023-3-1 19:10
这3个地方自己加一下代码

老师您好，麻烦您看看这个，该文件夹有很多其他的文件了，如何指定AAA这个文件，BBB文件表格格式也有所改（我在不以改变代码的情况下，也可以正常减去金额，前提是该文件夹中只有AAA和BBB文件）。如果要改代码的话，需要改那几个地方？谢谢！！！

shiruiqiang

i = InputBox("第几张表:")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Workbooks.Open (ThisWorkbook.Path & "\AAA.xlsx")
    brr = ActiveWorkbook.Sheets(i).UsedRange


            For j = 7 To UBound(brr)
                dic(brr(j, 3)) = brr(j, 7)
            Next j
    ActiveWorkbook.Close False

dzsrmyh

shiruiqiang 发表于 2023-3-2 07:22
i = InputBox("第几张表:")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = F ...

非常感谢，这下完美解决问题了

dzsrmyh

shiruiqiang 发表于 2023-3-2 07:22
i = InputBox("第几张表:")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = F ...

老师您好，能不能添加一个判断，就是如果AAA这个文件不存在的话，就弹出对话框提示该文件不存在，是否继续还是退出。