PDA

View Full Version : adapting code rename files doesn't contain comma ,dot



Kalil
10-01-2025, 12:46 AM
Hello,
I would adapt code to deal with amounts don't contain comma, dot are existed in files names .
sometimes I have files names like this
BBG 1000 MM
VVVV 100 BB
and the code deal just with this
QWE TY 8,000.00
ZE 400.00
so I would also deal with files names don't contain comma, dot when rename files again
to know what code does it
and here is original thread
http://www.vbaexpress.com/forum/showthread.php?72097-how-compare-file-name-with-lastrow-contains-comma-dot-when-file-is-open
here is code

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
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
" 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
thanks in advanced