Creation of data consolidation tool

[sebekkg]

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

 

[maabadi]

Welcome to MrExcel Message Board. Try This:

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]

Hi maabadi,
thanks for your replay.
I tried it and gives me error "Named argument not found" on line

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

 

[maabadi]

Sorry my fault Change it to

xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp)).Copy  DestSheet.Range("A" & Lr + 1)

 

[sebekkg]

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

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]

Try this:

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

 

[sebekkg]

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]

Change:

xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp).Row).Copy DestSheet.Range("A" & Lr + 1)

To

xWS.Range("A1:X" & Range("A" & Rows.Count).End(xlUp).Row).Copy

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

 

[sebekkg]

Maabadi, you are life saver. It works like a charm. I just added couple of message boxes and some buttons. Thanks a million.

 

[sebekkg]

@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?