Extraction amounts for each file name based on firs part in file name

Hello
I have file in folders and subfolders within this device "D:\REPORT\DATA"
so the files in folder and subfolders like this "D:\REPORT\DATA\PAID INVOICE NO 54,300.00"
"D:\REPORT\DATA\REPORT\RECEIVED INVOICE NO 15,056.00
most of extension for all of files will be excel All kinds .
the result will be in OUTPUT file is open to run the macro
the macro should do
1- make headers (ITEM,NAME FILE,MONTH ,RECEIVED,PAID)
2- auto number in column A
3- brings file names from folders, subfolders without extensions in column B.
4-brings month number in column C based on modified date in column C.
5-brings amount based on PAID , RECEIVED are existed in file name.
6- ignore any file doesn't contain PAID,RECEIVED words.
7- I expect to reach files counts could be 100 files through year .
8- should insert TOTAL row to sum column D,E
9- every time run the macro should replace data for OUTPUT file.
10- finally without forgetting numbers formatting.
I hope finding help from experts.

Welcome to VBAX Alaa. Normally speaking when members post threads, they are for singular items of interest. This type of question is possibly reaching into an area where you might have to consider a paid service for assistance, if someone wanted to take it on as a project.

thanks for inform me .if there is no body to see my thread I will search for the code in the internet and try to adapt based on my requirements.

where did you get the month number? there is no date on the excel file.

This is not tested, and follows your described requests in your first posts rather than the actual workbooks. As arnelgp has pointed out there are no specific dates in the files

Code:

---

Sub ExtractInvoiceData()
    Dim fso As Object
    ' FileSystemObject
    Dim topFolder As Object
    ' Folder object for the root directory
    Dim subFolder As Object
    ' Folder object for subdirectories
    Dim fileObj As Object
    ' File object
    Dim outputSheet As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim fileName As String
    Dim monthNumber As Integer
    Dim amount As Double
    Dim paidFound As Boolean
    Dim receivedFound As Boolean
    Dim nextRow As Long
    ' Set the folder to search
    Const START_FOLDER As String = "D:\REPORT\DATA"
    ' Set the name of the output sheet (assuming it exists)
    Const OUTPUT_SHEET_NAME As String = "Sheet1"
    ' Change if your sheet has a different name
    ' Create an instance of the FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Get the top-level folder
    Set topFolder = fso.GetFolder(START_FOLDER)
    ' Set the output sheet
    On Error Resume Next
    ' In case the sheet doesn't exist
    Set outputSheet = ThisWorkbook.Sheets(OUTPUT_SHEET_NAME)
    On Error GoTo 0
    ' If the output sheet doesn't exist, add one (you might want to handle this differently)
    If outputSheet Is Nothing Then
        Set outputSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        outputSheet.Name = OUTPUT_SHEET_NAME
    End If
    ' Clear existing data in the output sheet (except headers if they exist)
    outputSheet.Cells.ClearContents
    ' Write the headers  outputSheet.Cells(1, 1).Value = "ITEM"
    outputSheet.Cells(1, 2).Value = "NAME FILE"
    outputSheet.Cells(1, 3).Value = "MONTH"
    outputSheet.Cells(1, 4).Value = "RECEIVED"
    outputSheet.Cells(1, 5).Value = "PAID"
    ' Initialize the row counter
    nextRow = 2  i = 1 
    ' Function to recursively process folders
    Sub ProcessFolders(folder As Object)
        Dim subFldr As Object
        Dim file As Object
        Dim parts As Variant
        ' Loop through each file in the current folder
        For Each file In folder.Files
            ' Check if the file name contains "PAID" or "RECEIVED"
            If InStr(UCase(file.Name), "PAID") > 0 Or InStr(UCase(file.Name), "RECEIVED") > 0 Then
                ' Extract file name without extension
                fileName = Left(file.Name, InStrRev(file.Name, ".") - 1)
                ' Get the month number from the file's modified date
                monthNumber = Month(file.DateLastModified)
                ' Initialize amount and flags       
                amount = 0
                paidFound = False
                receivedFound = False
                ' Extract amount based on "PAID" or "RECEIVED"
                parts = Split(UCase(fileName), " ")
                For Each part In parts
                    If part = "PAID" Then
                        paidFound = True
                        ' Find the number after "PAID"
                        If IsNumeric(parts(UBound(Filter(parts, "PAID")) + 1)) Then
                            amount = CDbl(parts(UBound(Filter(parts, "PAID")) + 1))
                        ElseIf UBound(Filter(parts, ",")) > -1 Then
                            ' Handle cases with comma as decimal separator
                            amount = CDbl(Replace(parts(UBound(Filter(parts, "PAID")) + 1)), ",", "."))
                        End If
                    ElseIf
                        part = "RECEIVED" Then
                        receivedFound = True
                        ' Find the number after "RECEIVED"
                        If IsNumeric(parts(UBound(Filter(parts, "RECEIVED")) + 1)) Then
                            amount = CDbl(parts(UBound(Filter(parts, "RECEIVED")) + 1))
                        ElseIf UBound(Filter(parts, ",")) > -1 Then
                            ' Handle cases with comma as decimal separator
                            amount = CDbl(Replace(parts(UBound(Filter(parts, "RECEIVED")) + 1)), ",", "."))
                        End If
                    End If
                Next part
                ' Write the data to the output sheet
                With outputSheet
                  .Cells(nextRow, 1).Value = i
                  .Cells(nextRow, 2).Value = fileName
                  .Cells(nextRow, 3).Value = monthNumber
                  If receivedFound Then
                      .Cells(nextRow, 4).Value = amount
                    End If
                    If paidFound Then
                        .Cells(nextRow, 5).Value = amount
                    End If
                End With
                ' Increment counters
                nextRow = nextRow + 1
                i = i + 1
            End If
        Next file
        ' Recursively call this function for each subfolder
        For Each subFldr In folder.SubFolders
            ProcessFolders subFldr
        Next subFldr
    End Sub
    ' Start processing from the top folder 
    ProcessFolders topFolder
    ' Add the TOTAL row
    With outputSheet    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Cells(lastRow + 1, 1).Value = "TOTAL"
        .Cells(lastRow + 1, 4).Formula = "=SUM(D2:D" & lastRow & ")"
        .Cells(lastRow + 1, 5).Formula = "=SUM(E2:E" & lastRow & ")"
        ' Apply number formatting
        .Range("A2:A" & lastRow).NumberFormat = "0"
        ' Auto number
        .Range("D2:E" & lastRow + 1).NumberFormat = "#,##0.00"
        ' Amount with two decimal places
    End With
    ' Clean up object variables
    Set fileObj = Nothing
    Set subFolder = Nothing
    Set topFolder = Nothing
    Set fso = Nothing
    MsgBox "Invoice data extraction complete!", vbInformation
End Sub

---

Quote:

---

where did you get the month number? there is no date on the excel file.

---

I mentioned that

Quote:

---

4-brings month number in column C based on modified date in column C.

---

each file contains modified date when show properties inside folders.

thanks Aussiebear
I will check your code and see how goes at work tomorrow .

That's an unusual method for accounting.

see this demo also.

Aussiebear

I need correct syntax error show me red lines as bold to test your code!

Code:

---

amount = CDbl(Replace(parts(UBound(Filter(parts, "PAID")) + 1)), ",", "."))                        End If
                    ElseIf
                        part = "RECEIVED" Then
                        receivedFound = True
                        ' Find the number after "RECEIVED"
                        If IsNumeric(parts(UBound(Filter(parts, "RECEIVED")) + 1)) Then
                            amount = CDbl(parts(UBound(Filter(parts, "RECEIVED")) + 1))
                        ElseIf UBound(Filter(parts, ",")) > -1 Then
                            ' Handle cases with comma as decimal separator
                            amount = CDbl(Replace(parts(UBound(Filter(parts, "RECEIVED")) + 1)), ",", "."))

---

arnelgp
I would know how your code works. I have to write path for paid,received word in column C ?

Since you provided the worksheet name, this extracts PAID/RECEIVED value from the workbook, not from the file name.

Code:

---

Sub test()
    Dim myDir$, myList(), x
    Const wsName$ = "INVOICES"
    myDir = "D:\REPORT\DATA"
    On Error Resume Next
    x = Dir(myDir, vbDirectory)
    On Error GoTo 0
    If x = "" Then MsgBox "Wrong path", vbCritical: Exit Sub
    myList = SearchFiles(myDir, "*.xls*", 0, myList())
    On Error Resume Next
    x = UBound(myList)
    On Error GoTo 0
    If IsEmpty(x) Then MsgBox "No file found": Exit Sub
    GetData myList, wsName
End Sub


Sub GetData(myList, wsName$)
    Dim i&, ii&, e, f$, x, fn$, n&, a(), t&
    For i = 1 To UBound(myList, 2)
        e = myList(1, i)
        If (UCase$(e) Like "*\PAID*") + (UCase$(e) Like "*\RECEIVED*") Then
            n = n + 1: ReDim Preserve a(1 To 5, 1 To n)
            a(1, n) = n: fn = myList(2, i)
            a(2, n) = Left$(fn, InStrRev(fn, ".") - 1): a(3, n) = myList(3, i)
            a(4, n) = 0: a(5, n) = 0
            t = 4 + IIf(UCase$(fn) Like "*PAID*", 0, 1)
            f = "'" & Left$(e, InStrRev(e, "\")) & "[" & fn & "]" & wsName & "'!"
            a(t, n) = ExecuteExcel4Macro("vlookup(""NET""," & f & "C2:c5,4,false)")
        End If
    Next
    With Sheets("files").[a1].CurrentRegion.Offset(1)
        .Borders.LineStyle = xlNone
        .Font.Bold = False
        .Interior.ColorIndex = xlNone
        .ClearContents
        .Cells(0, 1).Copy .Cells(n + 1, 1)
        With .Resize(n)
            .Value = Application.Transpose(a)
            .Rows(.Rows.Count + 1) = Array("TOTAL", "", "", "=sum(r2c:r[-1]c)", "=sum(r2c:r[-1]c)")
            .Resize(.Rows.Count + 1).Columns("c:e").NumberFormatLocal = "#,##0.00;-#,##0.00;-;@"
            .Resize(.Rows.Count + 1).Borders.Weight = 2
        End With
        .Parent.UsedRange.HorizontalAlignment = xlCenter
    End With
End Sub


Function SearchFiles(myDir$, myFileName$, n&, myList()) As Variant
    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 "~$*") * (myFile.Name <> ThisWorkbook.Name) _
        * (myFile.Name Like myFileName) Then
            n = n + 1
            ReDim Preserve myList(1 To 3, 1 To n)
            myList(1, n) = myDir & "\" & myFile.Name
            myList(2, n) = myFile.Name
            myList(3, n) = Month(myFile.DateLastModified)
        End If
    Next
    For Each myFolder In fso.GetFolder(myDir).SubFolders
        SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
    Next
    SearchFiles = myList
End Function

---

Quote:

---

Originally Posted by Alaa

arnelgp
I would know how your code works. I have to write path for paid,received word in column C ?

---

Initially, you would write the correct path to Column C.
If the path I wrote is OK, you may press the "Process folders" button and it will create the Output.xlsx
on the folder you specified on Column C.

wow !
this is really awesome jindon.:yes
thank you so much.:friends:

Quote:

---

Initially, you would write the correct path to Column C.

---

ok I'm afraid your code takes much more time to running and in the end will be crash !

I update the code to not Open the workbooks and only look for the amount on the File name.

Quote:

---

I update the code to not Open the workbooks and only look for the amount on the File name.

---

there is something wrong!
the code repeats extraction file names twice for the same file name for some files and ignore files within subfolders!

do you have same filename with .xlsx and .xlsm extension?
maybe that is the reason for dups.
modified to add sort to the month.

Quote:

---

do you have same filename with .xlsx and .xlsm extension?

---

no I haven't
finally works well.:thumb
many thanks:yes