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.Sheet s.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 (http://www.vbaexpress.com/forum/member.php?3907-Aussiebear)
Thanks but there are syntax error

[maghari]

but I guess the OP is not interested anymore
sorry for delaying !!: pray2:
your code is excellent.:thumb
many thanks Jindon for your help.:clap2:

[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.