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]

you want remove duplicate based which column?

 

[sebekkg]

All columns from A:X I've added two columns where i get data trough vlookup from other sheet, so i would not use that as an criteria for duplicates since it is generated based on column from raw data.

 

[maabadi]

you want remove duplicate Rows or Columns?

 

[sebekkg]

I would like to remove duplicate rows, based on values in columns A:X, And it would be nice to be in a ListObject so I preserve two additional columns with VLOOKUP in them.

 

[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, Rng as Range, objTable As ListObject
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
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
Set Rng = DestSheet.Range("A1:X" & Lr)
Set objTable = DestSheet.ListObjects.Add(xlSrcRange, Rng, , xlYes)
Rng.RemoveDuplicates Columns:=Array(1, 24), Header:=xlYes

xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[sebekkg]

@maabadi
Thanks man, I made tiny changes and it works great. Thanks for this. But only thing that bothers me a little bit is first empty row after the header.

 

[maabadi]

If you test with separate data And See the Same Issue, We can Remove Row 2 (If I understand correctly). Than add this line to code After this line

Rng.RemoveDuplicates Columns:=Array(1, 24), Header:=xlYes

Add this:

DestSheet.Range("A2").EntireRow.Delete Shift:=xlUp

 

[sebekkg]

I managed to do it with this line, just added condition if there is no data imported and it works great. Just for the remove of duplicate rows I used your logic but entered columns manually and it works. For some reason with adding only columns indexes didn't do a trick. so I added:

Range("RawData[[#Headers],[db]:[Additional Comments]]").Select
    ActiveSheet.Range("RawData[#All]").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, _
        6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), Header:=xlYes