VBA to transfer multiple data into one tab, troubleshooting

[Nightlytic]

Hi,

Can someone review my macro? Working on Excel 2010 here. I have multiple workbooks, one for analysis (here called x) and one for data (here called y) and I am working on a code to transfer data from workbooks y (based on file path listed in workbook x, column L, starting at "L17" named MyPath) to an output tab, immediately below whatever code is already there. Here is the code so far:

Sub CopyDataOver()
'Optimise settings
Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

' Declare workbooks:
Dim x As Workbook
Dim y As Workbook
MyPath = Range("L17")
Set y = ThisWorkbook
Set x = Workbooks.Open(MyPath)


'remove extra data in sheet x (data)
x.Sheets("Sheet1").Range("A1").Copy
x.Sheets("Sheet1").Range("A1").EntireRow.Delete
x.Sheets("Sheet1").Range("A1").End(xlDown).Offset(1, 0).EntireRow.Delete
x.Sheets("Sheet1").Range("A1").End(xlDown).Offset(1, 0).EntireRow.Delete
x.Sheets("Sheet1").Range("A1").End(xlDown).Offset(1, 0).EntireRow.Delete

'move data to y (analysis)
Set CopyRange = x.Sheets("Sheet1").Range("A1:Z5000").CurrentRegion
Set PasteRange = y.Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
PasteRange.Value = CopyRange.Value

'Close x:
Application.DisplayAlerts = False
x.Close False
Application.DisplayAlerts = True

  'Reset settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

It 'works', my issues though:
1. the part on pasting data, I only pastes the value from top left corner. I've no idea why
2. Could you suggest a way for me to loop this, it's a bit beyond my ability. I need the macro to then declare the next cell, L18, L19 and so on, as the workbook and copy data over from those as well. Move on to the next L value if it can't find the file, and stop if the cell in L is a "" value (the hyperlinks are formulae that list files within a folder, and give a "" if there are none left.
3. Minor, but there are sometimes totals in the data that you can see me pitifuly trying to get rid of:
x.Sheets("Sheet1").Range("A1").End(xlDown).Offset(1, 0).EntireRow.Delete
Is there a way perhaps to modify this so that it looks at the last A1 value there
x.Sheets("Sheet1").Range("A1").End(xlDown).Offset(0, 0).EntireRow.Delete
I presume that? And then deletes it if and only if the A value there is "" or a space? There are no totals on A it's a reference point so I just want to delete anything that is empty there, but without running a macro to delete empty values across the entire sheet, just at the last 3 rows, for performance sake.

If you see any optimisation opportunities, please let me know, I have no idea how smoothly this will run, technically I envision it opening c.5-10 workbooks at a time, transferring c.10-20k rows of data

Thank you for any help

 

[Nightlytic]

Btw, I realise the above is pretty heavy, please just take a look and give tips wherever you can don't need a silver bullet one-fix-all solution. I've been working on this and researching for a while now, I just wanted a bit of a dig-out...

 

[Chihiro]

Please upload sample file for both the source and the destination. Clearly indicating your current result and what your desired output is. It will make it so much easier for us to help you.

Your code's main issue is here, from what I can see.

Set CopyRange = x.Sheets("Sheet1").Range("A1:Z5000").CurrentRegion
Set PasteRange = y.Sheets("Output").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
PasteRange.Value = CopyRange.Value

Your PasteRange is set to Single cell. If you want to put all value from CopyRange, you'd need exactly same number of columns and rows for PasteRange. Or just use Excel's native ".Copy" method instead of Range.Value = Range.Value method.

 

[Nightlytic]

Hi, Thank you Chihiro,

Yeah I normally would attach a file but my workbook got very complex and it's difficult to illustrate without the files feeding in.

I actually made progress on looping it all together today! Working on getting the data to paste at end o range now. Ill try your fix and be right back!

 

[Nightlytic]

So this is the attempt I'm making now,

And attached sample of what data I'm looking at (but mind that each run of the macro, a bunch of these will load up, and all stack on top of each other to create one large dataset to analyse). I Might just filter out the headings and totals, if I can't remove them with VBA, so it's not too bad I guess to just copy the .currentregion .

The looping seems to work fine, the pasting still no luck, I might also need to insert error handling around the paths, in a situation where a file doesn't exist I would like it to say (in corresponding row of column C) that the file was "not loaded"

Any tips let me know

 

[Nightlytic]

Ah this works :
x.Sheets("Sheet1").Range("A1").CurrentRegion.Copy
y.Sheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

 

[Nightlytic]

Alright, I'm done

I think I gained 10 experience in VBA today. Ideas on performance? seems to work on 5 workbooks alright, I might try 50...

Public Sub DownloadData()
'Optimise settings
Application.ScreenUpdating = True
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
 
Dim x As Workbook
Dim y As Workbook
Set y = ThisWorkbook
Application.DisplayAlerts = False
    ' Go through cells:
    Dim i As Long
    For i = 2 To 10
        ' Play with workbooks:
     
        If y.Sheets("Retrieve").Range("B" & i).Value <> "" Then
   
        Set x = Workbooks.Open(y.Sheets("Retrieve").Range("D" & i))
        x.Sheets("Sheet1").Range("A1").EntireRow.Delete
        If x.Sheets("Sheet1").Range("A1").End(xlDown) = "" Then
        x.Sheets("Sheet1").Range("A1").End(xlDown).EntireRow.Delete
        End If
       
        If x.Sheets("Sheet1").Range("A1").End(xlDown) = "" Then
        x.Sheets("Sheet1").Range("A1").End(xlDown).EntireRow.Delete
        End If
       
        If x.Sheets("Sheet1").Range("A1").End(xlDown) = "" Then
        x.Sheets("Sheet1").Range("A1").End(xlDown).EntireRow.Delete
        End If
       
       
        x.Sheets("Sheet1").Range("A1").CurrentRegion.Copy
        y.Sheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        x.Close
'close the data workbook before moving on


    'confirm data was loaded
    y.Sheets("Retrieve").Range("C" & i).Value = "Loaded"
    'Wait for dramatic effect
    Application.Wait Now + #12:00:01 AM#
       
       
        End If
    Next


Application.DisplayAlerts = True
'Reset settings:
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
End Sub

 

[Marc L]

Hi !

Within your code why repeating the same action 3 times ?‼

And the If codelines may not work on a range of cells …
And the loop seems odd too !

Not logical !

Check your code in debug mode, step by step via F8 key …
​