Creation of data consolidation tool

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Hello guys,
I am new at vba but I need your help.
I would like to create a tool in excel(VBA) that would do next:
Open Folder picker and select folder which contains multiple excel files.
All of them would have one sheet (but with different names).
Loop through all these excel files copy data and past into my initial excel file.
Data in those excel files starts from A4 to X4 cells and can goes down (like CTRL+SHIFT).
In the initial excel file, in the sheet where it would all go, I would like to have first row filled with column names so that would not be erased.
and when data is appended it goes to first empty cell in column A then and past data.
Also if possible that with one button I go trough data and remove duplicate rows and one to clear all data in sheet besides first row.


For you this might be over explained but I just want to be sure that I have not made any mistake here :)
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,792
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Welcome to MrExcel Message Board. Try This:
VBA Code:
Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog
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
Set Sh1 = Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp)).Copy After:=DestSheet.Range("A" & Lr + 1)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Hi maabadi,
thanks for your replay.
I tried it and gives me error "Named argument not found" on line

VBA Code:
xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp)).Copy[COLOR=rgb(209, 72, 65)] After:=[/COLOR]DestSheet.Range("A" & Lr + 1)
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,792
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Sorry my fault Change it to
VBA Code:
xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp)).Copy  DestSheet.Range("A" & Lr + 1)
 

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

I tried to run it again but it gives an error Wrong number of arguments or invalid property assignment.

VBA Code:
xTWB.Save FileFormat:=xlWorkbookNormal


If i remove part with file format, it doesn't give an error but there is no data in my main excel file.
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,792
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Try this:
VBA Code:
Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
Debug.Print DestSheet.Name
  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
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp).Row).Copy DestSheet.Range("A" & Lr + 1)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Solution

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

This works great. Thank you, Maabadi.
Can I just ask you if it is possible to paste values only. instead of classic copy paste?
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,792
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Change:
VBA Code:
xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp).Row).Copy DestSheet.Range("A" & Lr + 1)
To
VBA Code:
xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp).Row).Copy

DestSheet.Range("A" & Lr + 1).PasteSpecial Paste:=xlPasteValues
 

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Maabadi, you are life saver. It works like a charm. I just added couple of message boxes and some buttons. Thanks a million.
 

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
@maabadi
Quick question:
If I would like to have in active sheet an table (ListObject) because I would like to have some formulas added to this data that I am consolidating, is it possible to modify previous vba code and use it for this purpose? And also remove duplicate rows?
 

Watch MrExcel Video

Forum statistics

Threads
1,129,535
Messages
5,636,884
Members
416,946
Latest member
mniceguy81

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top