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 :)
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,583
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
you want remove duplicate based which column?
 

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Oct 22, 2012
Messages
1,583
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
you want remove duplicate Rows or Columns?
 

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Oct 22, 2012
Messages
1,583
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

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, 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

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
@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.
 

Attachments

  • Capture.PNG
    Capture.PNG
    40.2 KB · Views: 2

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,583
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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
VBA Code:
Rng.RemoveDuplicates Columns:=Array(1, 24), Header:=xlYes
Add this:
VBA Code:
DestSheet.Range("A2").EntireRow.Delete Shift:=xlUp
 

sebekkg

New Member
Joined
Jan 21, 2021
Messages
10
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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:

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,123
Messages
5,622,870
Members
415,935
Latest member
kes1973

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