VBA transfer data from multiple wkbks into master wkbk -copies multiple times same data

Clairexcel

New Member
Joined
Mar 23, 2021
Messages
31
Office Version
  1. 2016
  2. 2010
Hello again everyone,
I have another VBA code that I have been trying to adapt to my needs (it is a code I found so I did not write it) that should transfer data from 4 workbooks (all in the same folder) into master workbook.
Now every workbook has the same name on sheet 1 which is the sheet that has to be copied into the masterbook on a sheet with also the same name.
It works perfectly the first time, but if I click the command button again to refresh the data (that other users may have added in their workbooks meanwhile), it copies again all the data bellow the occupied rows. That means I have double entries of data, and if I click a third time the macro button it copie below alla the data , so then I would have three times the same data..
Could anyone please tell me what should I modify so that whenever one clicks the command button with the macro can get the all data from the other workbooks without repeating it...I hope I explained myself.
Another issue I have is that it copies the headers from all the sheets, but I want it to only cpoy data without the headers, because in the masterworkbook/mastersheet I already have the headers. I tried tweaking the Offset of the UsedRange but if I set it to (2) it will leave out the first used row when it transfers the data to master wkbk
Here is the code I have:
VBA Code:
Sub Vedipratiche()
Dim wb As String
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
'offset 4 value tells to which row in the master workbook to start copying
With Workbooks(wb).Sheets(1)
.UsedRange.Offset(1).Copy ThisWorkbook.Sheets("Aggiornapratiche").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
Application.CutCopyMode = False
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Thank you in advance for any help or suggestions.
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,551
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
How about adding this one line as indicated. I was not getting the same issues as you with regards to repeated headers.

Please test on a back up copy of your work, as this code will delete data that is not normally recoverable.

VBA Code:
Sub Vedipratiche()

    Dim wb As String
    
    Application.ScreenUpdating = False
    ThisWorkbook.Worksheets("Aggiornapratiche").UsedRange.Offset(1, 0).ClearContents  '*** Added Line
    wb = Dir(ThisWorkbook.Path & "\*")
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & wb
            'offset 4 value tells to which row in the master workbook to start copying
            With Workbooks(wb).Sheets(1)
                .UsedRange.Offset(1).Copy ThisWorkbook.Sheets("Aggiornapratiche").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End With
            Application.CutCopyMode = False
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
    
End Sub
 
Solution

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,776
Hi Claire. This seems like it should work. Please save a copy of your wb before trial. HTH. Dave
Code:
Dim LastRowA As Long, LastCol As Long
With Workbooks(wb).Sheets(1)
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, "A"), .Cells(LastRowA + 1, LastCol)).Copy _
Destination:=ThisWorkbook.Sheets("Aggiornapratiche").Range("A" & 2)
End With
ps. U need to replace the relevant part of the code
 

Clairexcel

New Member
Joined
Mar 23, 2021
Messages
31
Office Version
  1. 2016
  2. 2010
@igold and @NdNoviceHlp , thank you so much, very appreciated! I will test both solutions and give yuo feed back.
The header thing was my fault, as in the sheets in the normal wkbks rows were starting at row 2. So I put the headers in row 1 and I got rid of the problem.
Again thank you and I will let you know today :)
 

Watch MrExcel Video

Forum statistics

Threads
1,130,342
Messages
5,641,592
Members
417,224
Latest member
llama9207

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