Level of Excel (God)

[Tofik]

Hi Guys, the new challenge for you ?
It can be harder to create but I saw from one guy who used this function in excel in our job and won't create the same thing.
I have a lot of the same routine reports in my folder on my PC for example my C:\Folder With reports and all reports structures are the same ( only some values can be dinamic ).

and now I want to collect all information in one excel file (for example A1 from all reports in a folder to one excel file )

and if I know that, all excel files in the folder have the same table ( table are static ), and only value in those cells are changing ( Dynamic )
all reports in this condition :

CON-PIP-12-T-S001.xlsx
	A	B	C	D	E	F	G	H	I
1	No	Example of info					date
2							report NO 0001
3	1	same name in all reports	value which dinamic	value which dinamic	value which dinamic
4	2	same name in all reports	value which dinamic	value which dinamic	value which dinamic
5	3	same name in all reports	value which dinamic	value which dinamic	value which dinamic
6	4	same name in all reports	value which dinamic	value which dinamic	value which dinamic
7	5
8	6
9	7
10	8
11	9
Sheet3

How it should be in one excel :

CON-PIP-12-T-S001.xlsx
	A	B	C	D	E	F	G	H	I
1	No	Example of info					date
2							report NO 0001
3	1	same name in all reports	value which dinamic	value which dinamic	value which dinamic
4	2	same name in all reports	value which dinamic	value which dinamic	value which dinamic
5	3	same name in all reports	value which dinamic	value which dinamic	value which dinamic
6	4	same name in all reports	value which dinamic	value which dinamic	value which dinamic
7	5
8	6
9	7
10	8
11	9
12
13
14	No	Example of info					date
15							report NO 0002
16	1	same name in all reports	value which dinamic	value which dinamic	value which dinamic
17	2	same name in all reports	value which dinamic	value which dinamic	value which dinamic
18	3	same name in all reports	value which dinamic	value which dinamic	value which dinamic
19	4	same name in all reports	value which dinamic	value which dinamic	value which dinamic
20	5
21	6
22	7
23	8
24	9
Sheet3

the reason why I need this because of the routine which kills me to open one excel to copy info to my final Log and also my laptop has only 4 Ram which freezing all the time and I spend so much time on it.
I can automate the system which can save my time to copy-paste all info into one.

Thank you, guys. If you can solve it, it will be perfect for me and also thanks for your time.

 

[maabadi]

We can do it, what about use Row 1 & 2 as Headers . AND Add one column at first as Filename (Column A).

 

[maabadi]

AND
1. you want to merge all sheets in each file or only one specific sheet? ( if One, what is Sheet name?)
2. what is your last column
3. Can we use Column A to find Last row of each file ( if Last row is same for all, what is Last Row?)

 

[Tofik]

We can do it, what about use Row 1 & 2 as Headers . AND Add one column at first as Filename (Column A).

it's good idea

 

[SpillerBD]

Combining Multiple files of Excel with the same Schema is done using PowerQuery.
The MVP you're looking for is Mike Girvin ExcelIsFun. He has a lesson on PowerQuery combining multiple files in the same folder.

 

[maabadi]

1. you want to merge all sheets in each file or only one specific sheet? ( if One, what is Sheet name?)
2. what is your last column
3. Can we use Column A to find Last row of each file ( if Last row is same for all, what is Last Row?)

 

[maabadi]

Try this VBA Macro. This macro find last column & Row Based First Row & First Column. if you want others, Please tell.

Sub ImportFiles3()
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
Dim os As Long, LrS As Long, LCS As Long, FileName As String
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = "Master" Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(DestSheet.Cells(1, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"
End If
     Set Head = xWS.Range("A1")
       For os = 0 To xWS.Cells(1, Columns.Count).End(xlToLeft).Column - 1
            On Error Resume Next
            Header = 0
            Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
            On Error GoTo 0
           
            If Header = 0 Then
                DestSheet.Cells(1, LCD) = Head.Offset(0, os)
                Header = LCD
                LCD = LCD + 1
            End If
    If Lr = 1 Then
      Range(DestSheet.Cells(Lr + 2, Header), DestSheet.Cells(Lr + LrS - 1, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
    Else
      Range(DestSheet.Cells(Lr + 1, Header), DestSheet.Cells(Lr + LrS - 2, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
    End If
     Next os
     If Lr = 1 Then
     Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
     Else
     Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
     End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
DestSheet.Activate
DestSheet.Name = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[maabadi]

Sorry I forgot to Tell You Previous macro only extract "master" Sheet from each file & and do it column by column.
This is another version that extract only sheet1 but all at one time (without Column by column).
if you want another sheet change name within macro & if you want all sheet for all files then we should change macro:

Sub ImportFiles3()
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
Dim os As Long, LrS As Long, LCS As Long, FileName As String
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = "Sheet1" Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(DestSheet.Cells(1, 2), DestSheet.Cells(LrS, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"
Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
Else
Range(DestSheet.Cells(Lr + 1, 2), DestSheet.Cells(Lr + LrS - 2, LCS)).Value = Range(xWS.Cells(3, 1), xWS.Cells(LrS, LCS)).Value
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
End If
     
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
DestSheet.Activate
DestSheet.Name = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[maabadi]

And One problem, Change Last Number 2 at first line these lines to LrS

Range(DestSheet.Cells(1, 2), DestSheet.Cells(LrS, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"

TO

Range(DestSheet.Cells(1, 2), DestSheet.Cells(LrS, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(LrS, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"

Then code is:

Sub ImportFiles3()
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
Dim os As Long, LrS As Long, LCS As Long, FileName As String
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = "Sheet1" Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(DestSheet.Cells(1, 2), DestSheet.Cells(LrS, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(LrS, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"
Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
Else
Range(DestSheet.Cells(Lr + 1, 2), DestSheet.Cells(Lr + LrS - 2, LCS)).Value = Range(xWS.Cells(3, 1), xWS.Cells(LrS, LCS)).Value
Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
End If
     
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
DestSheet.Activate
DestSheet.Name = "Consolidate"
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Tofik]

AND
1. you want to merge all sheets in each file or only one specific sheet? ( if One, what is Sheet name?)
2. what is your last column
3. Can we use Column A to find Last row of each file ( if Last row is same for all, what is Last Row?)

1) all reports have only one sheet and in all reports sheet name is 10140-CON-PIP-12
2) I attach our excel file mark by (yellow highlighting and red ) the main places which I need
3) don't understand

Report 1.xlsx

drive.google.com