Sub test()
Dim myDir As String, temp(), myList
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1)
End With
If myDir = "" Then Exit Sub
myList = SearchFiles(myDir, 0, temp())
If IsError(myList) Then MsgBox "No file found": Exit Sub
DoIt myList
End Sub
Private Function SearchFiles(myDir$, n&, myList)
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(myDir).Files
If (Not myFile.Name Like "~$*") * (UCase$(myFile.Name) Like UCase$("*.xls*")) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = myDir & "\"
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(myDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, n, myList)
Next
SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function
Sub DoIt(ByVal myList)
Dim i&, fn$, myAmount$, wsName$, s$, x, msg$, g
For i = 1 To UBound(myList, 2)
fn = myList(1, i) & myList(2, i)
If fn <> ThisWorkbook.FullName Then
myAmount = GetAmount(CStr(myList(2, i)))
If myAmount Like "*#.00" Then
wsName = GetWsName(fn)
s = "'" & myList(1, i) & "[" & myList(2, i) & "]" & wsName & "'!"
x = ExecuteExcel4Macro("match(""total""," & s & "c5:c5,0)")
If Not IsError(x) Then
g = ExecuteExcel4Macro(s & "r" & x & "c7")
x = ExecuteExcel4Macro("sum(" & s & "r9c7:r" & x - 1 & "c7)")
If myAmount <> Format$(x, "#,###.00") Then
MsgBox "Update Total from " & g & " to " & x & " in " & vbLf & fn, , "Wrong Total"
UpdateAmount myList(1, i) & myList(2, i), wsName, x
s = myList(1, i) & Replace(myList(2, i), myAmount, x)
If Dir(s) = "" Then
Name fn As myList(1, i) & Replace(myList(2, i), myAmount, Format$(x, "#,###.00"))
Else
msg = msg & vbLf & Replace(myList(2, i), myAmount, Format$(x, "#,###.00")) & vbLf & _
" is already exists in the same folder"
End If
End If
End If
End If
End If
Next
If Len(msg) Then MsgBox msg
End Sub
Function GetWsName$(fn$)
GetWsName = Replace(CreateObject("DAO.DBEngine.120").OpenDatabase(fn, _
False, False, "excel 5.0;hdr=no;").tabledefs(0).Name, "$", "")
End Function
Function GetAmount$(fn$)
With CreateObject("VBScript.RegExp")
.Pattern = "\b\d{1,3}(,\d{3})*\.00*\b"
If .test(fn) Then GetAmount = .Execute(fn)(0)
End With
End Function
Sub UpdateAmount(fn$, wsName$, myAmount)
Dim s$
s = "Update `" & wsName & "$E8:G` Set `Balance` = " & myAmount & " Where `C#N` = 'TOTAL';"
With CreateObject("ADODB.Connection")
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 8.0"
.Open fn
.Execute s
End With
End Sub