populate summary separated range for each name across files for same sheet name

[maghari]

Hi,
I would extract data from the same sheet name from EXTRACTION sheet across files to new file
the new file should add automatically based on date(today) as the name shows SUMMARY RANGES 01-05-2025 , but if I run the macro every time in date today then should replace file(not add many files for the same day ).
so I put sample result in SUMMARY RANGES 01-05-2025 file how should be .
so in column B should show header for each name is existed in column B for each file .
should brings SUMMARY range is existed to bottom for each file , in column A should show ITEMS (1,2,3..)
after brings summary range for each name should create total summary for whole names by sum duplicates items in column B
the files could be 150 files in this directory "C:\Users\MMGG\Desktop\SUMMARY DAYS"
becarful in my real project every EXTRACTION sheet contains sheet before it so this sheet is not first , could be fourth, fivth.... you can say changeable in location .
thanks

[Aussiebear]

This will get you started, note however that it doesn't include the Summary data that you want as you will need to define the Summary data better.

Sub SummarizeExtractionData()
    Dim fso As Object 
    ' FileSystemObject
    Dim folderPath As String
    Dim objFolder As Object 
    ' Folder object
    Dim objFile As Object 
    ' File object
        Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim todaysDate As String
    Dim summaryFileName As String
    Dim filePath As String
    Dim fileExists As Boolean
    ' Set the folder path
    folderPath = "C:\Users\MMGG\Desktop\Summary days\"
    ' Get today's date in YYYYMMDD format for the filename
    todaysDate = Format(Date, "YYYYMMDD")
    summaryFileName = "Summary_" & todaysDate & ".xlsx"
    ' Construct the full path for the summary file
    filePath = Environ("USERPROFILE") & "\Desktop\" & summaryFileName 
    ' Assuming you want to save on the Desktop
    ' Check if the summary file already exists
    fileExists = Dir(filePath) <> ""
    ' Create or open the target workbook
    If fileExists Then
        Set targetWorkbook = Workbooks.Open(filePath)
        ' Check if the "Summary" sheet exists, if not add it
        On Error Resume Next
        Set targetSheet = targetWorkbook.Sheets("Summary")
        On Error GoTo 0
        If targetSheet Is Nothing Then
            Set targetSheet = targetWorkbook.Sheets.Add(After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count))
            targetSheet.Name = "Summary"
        End If
    Else
        Set targetWorkbook = Workbooks.Add
        Set targetSheet = targetWorkbook.Sheets.Add        
        targetSheet.Name = "Summary"
    End If
    ' Create a FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Get the folder object
    Set objFolder = fso.GetFolder(folderPath)
    ' Loop through each file in the folder
    For Each objFile In objFolder.Files
        ' Check if the file is an Excel file (you might want to refine this check)
        If InStr(1, objFile.Name, ".xls", vbTextCompare) > 0 Then
            ' Open the source workbook (without updating links or read-only prompt)
            Set sourceWorkbook = Workbooks.Open(objFile.Path, UpdateLinks:=False, ReadOnly:=True)
            On Error Resume Next 
            ' Handle the case where the "Extraction" sheet doesn't exist
            Set sourceSheet = sourceWorkbook.Sheets("Extraction")
            On Error GoTo 0
            ' Check if the "Extraction" sheet was found
            If Not sourceSheet Is Nothing Then
                ' Find the last used row in the target sheet
                lastRow = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row
                ' If it's the first time adding data, start from row 1, otherwise go to the next empty row
                If lastRow > 1 Or (lastRow = 1 And IsEmpty(targetSheet.Cells(1, 1))) Then
                    lastRow = lastRow + 1
                Else
                    lastRow = 1
                End If
                ' Get the last used row in the source sheet
                Dim sourceLastRow As Long
                sourceLastRow = sourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
                ' Copy all data from the "Extraction" sheet to the target sheet
                sourceSheet.UsedRange.Copy targetSheet.Cells(lastRow, 1)
            Else
                MsgBox "Sheet 'Extraction' not found in file: " & objFile.Name, vbExclamation
            End If
            ' Close the source workbook without saving
            sourceWorkbook.Close 
            SaveChanges:=False
            Set sourceWorkbook = Nothing
            Set sourceSheet = Nothing
        End If
    Next objFile
    ' Save the target workbook    
    targetWorkbook.SaveAs filePath
    ' Release object variables
    Set fso = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
    Set targetSheet = Nothing
    Set targetWorkbook = Nothing
    MsgBox "Data from 'Extraction' sheets in '" & folderPath & "' has been summarized in '" & filePath & "'", vbInformation
End Sub

As I indicated earlier, if you were to perhaps name the Summary data range as a table then we could look at extracting the table and then look at the layout of the data on the destination sheet.

[jindon]

Do not open any related workbook, otherwise it will be very slow.
Create a new workbook and paste the code and save as .xlsm then run the code from there.

Sub test()
    Dim a, myDir$, fn$, f$, cn$, x(), i&, ii&, n&, myRow
    Const wsName$ = "EXTRACTION"
    myDir = "C:\Users\MMGG\Desktop\SUMMARY DAYS"
    If Dir(myDir, vbDirectory) = "" Then MsgBox "Wrong path", vbCritical, myDir: Exit Sub
    cn = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=#;Extended Properties='Excel 12.0;HDR=Yes';"
    ReDim a(1 To 50000, 1 To 3)
    fn = Dir(myDir & "\*.xls*")
    Do While fn <> ""
        If Not UCase$(fn) Like "SUMMARY*" Then
            f = "'" & myDir & "\[" & fn & "]" & wsName & "'!"
            If Not IsError(ExecuteExcel4Macro(f & "r1c1")) Then
                myRow = ExecuteExcel4Macro("match(""SUMMARY:""," & f & "c3:c3,0)")
                If Not IsError(myRow) Then
                    With CreateObject("ADODB.Recordset")
                        .Open "Select * From `" & wsName & "$C" & myRow & ":D`;", Replace(cn, "#", myDir & "\" & fn)
                        n = n + 1
                        ReDim Preserve x(1 To 3, 1 To n)
                        x(1, n) = ExecuteExcel4Macro(f & "r7c2")
                        x(2, n) = .GetRows
                        For i = 0 To .Fields.Count - 1
                            x(3, n) = x(3, n) & IIf(x(3, n) <> "", Chr(2), "") & .Fields(i).Name
                        Next
                        x(3, n) = "ITEM" & Chr(2) & x(3, n)
                    End With
                End If
            End If
        End If
        fn = Dir
    Loop
    If n Then ReDim Preserve x(1 To 3, 1 To n): GetDetails x, myDir
End Sub


Sub GetDetails(x, myDir$)
    Dim a, e, i&, ii&, n&, myRows, dic As Object, ref&
    Dim ws As Worksheet, r As Range
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Sheets.Add
    ReDim a(1 To UBound(x, 2) * 100, 1 To 3)
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(x, 2)
        n = n + 1: a(n, 2) = "NAME"
        n = n + 1: a(n, 2) = x(1, i)
        n = n + 1
        a(n, 1) = Split(x(3, i), Chr(2))(0): a(n, 2) = Split(x(3, i), Chr(2))(1)
        a(n, 3) = Split(x(3, i), Chr(2))(2): ref = 0
        For ii = 0 To UBound(x(2, i), 2)
            n = n + 1: ref = ref + 1: a(n, 1) = ref
            a(n, 2) = x(2, i)(0, ii): a(n, 3) = x(2, i)(1, ii)
            dic(x(2, i)(0, ii)) = dic(x(2, i)(0, ii)) + x(2, i)(1, ii)
        Next
        n = n + 1
    Next
    ws.[a1].Resize(n, 3) = a
    For Each r In ws.Columns(1).SpecialCells(2).Areas
        With r.CurrentRegion
            With .Cells(1, 2)
                .Font.Bold = True
                .Interior.Color = vbYellow
                .Borders.Weight = 2
            End With
            Union(.Rows(3), .Columns(1)).Font.Bold = True
            .Rows(3).Interior.Color = vbYellow
            .Offset(2).Resize(.Rows.Count - 2).Borders.Weight = 2
        End With
    Next
    With ws.Range("a" & Rows.Count).End(xlUp)(4).Resize(, 3)
        .Range("b1") = "TOTAL NAMES"
        With .Rows(2)
            .Value = Split(x(3, 1), Chr(2))
            .Font.Bold = True
            .Interior.Color = vbYellow
        End With
        With .Rows(3).Resize(dic.Count)
            .Columns(1) = Evaluate("row(1:" & dic.Count & ")")
            .Columns(1).Font.Bold = True
            .Columns("b:c") = Application.Transpose(Array(dic.keys, dic.items))
        End With
        .Rows(2).Resize(dic.Count + 1).Borders.Weight = 2
    End With
    With ws.UsedRange
        .Columns.AutoFit
        .HorizontalAlignment = xlCenter
        .Columns(3).NumberFormatLocal = "#,###.00"
    End With
    ws.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs myDir & "\SUMMARY RANGES " & Format$(Date, "dd-mm-yyyy"), 51
    ws.Delete
    Application.DisplayAlerts = True
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

[Aussiebear]

Very nice Jindon.

[jindon]

Thanks, but I guess the OP is not interested anymore...

[Aussiebear]

It may be just because its the weekend. Even if the OP doesn't come back you have still posted a great section of code.

[maghari]

@Aussiebear
Thanks but there are syntax error

[maghari]

but I guess the OP is not interested anymore

sorry for delaying !!
your code is excellent.
many thanks Jindon for your help.

[Aussiebear]

Sometimes when posting the code to the forum, the layout gets a little screwed up. I should have paid more attention to the layout.