VBA Code help!

superfb

Board Regular
Joined
Oct 5, 2011
Messages
121
Hi All,

I found this Macro code that allows me to copy data from multiple files from various locations in to the designated tabs.

But i feel the coding is quite clunky and im having issues where the data isnt picking up the format - this could be because the tables that are being copied over they have merged cells?

Also in regards to the code the various tables have obviously different number of rows how can i make sure its being picked up in different spreadsheets rather than designating a row number in tehe vba code?

VBA Code:
Public strFileName As String
Public currentWB As Workbook
Public dataWB As Workbook
Public strCopyRange As String

Sub GetData()
    Dim strWhereToCopy As String
    Dim strStartCellColName As String
    Dim strListSheet As String
   
    strListSheet = "List"
   
    'On Error GoTo ErrH
    Sheets(strListSheet).Select
    Range("B2").Select
   
    'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
    Set currentWB = ActiveWorkbook
    Do While ActiveCell.Value <> ""
       
        strFileName = ActiveCell.Offset(0, 1) '& ActiveCell.Value ' think it adds filpath then filename - can swap i think
        strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
       
        'strWhereToCopy = currentWB.Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
     
        'ActiveCell.Offset(0, 4).Value 'tab
       
     
        'strCopyRange = ActiveCell.Offset(0, 2) & ":" & ActiveCell.Offset(0, 3) 'starts at b2 - links to col d and e
       
       
        Application.Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True
       
        Set dataWB = ActiveWorkbook
        strCopyRange = Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
        Columns("A:G").Select
        Selection.Copy
       
        'Range(strCopyRange).Select
        'Selection.Copy
       
          Windows("vba-macro-to-copy-data-from-multiple-files2.xlsm").Activate
        'Sheets(strWhereToCopy).Select
        strWhereToCopy = currentWB.Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
     
        'lastRow = LastRowInOneColumn(strStartCellColName)
        'Cells(lastRow + 1, 1).Select
       
       
       
        Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
        Application.CutCopyMode = False
        dataWB.Close False
        LastCol = LastColInOneRow(strStartCellColName)
        'Cells(LastCol + 1, 1).Select
       
        Sheets(strListSheet).Select
        ActiveCell.Offset(1, 0).Select
    Loop
    Exit Sub
   
'ErrH:
    'MsgBox "It seems some file was missing. The data copy operation is not complete."
    'Exit Sub
End Sub

Public Function LastColInOneRow(col)
    'Find the last used col in a row: column A in this example

    Dim LastCol As Long
   
    With ActiveSheet
    Sheets("All").Range("A5").Select
    LastCol = Selection.End(xlToRight).End(xlUp).Select

   
   
    'LastCol = .Cells(5, .Columns.Count).End(xlLeft).col
    End With
    LastColInOneRow = LastCol
End Function

'Sub LastColumnInOneRow()
'Find the last used column in a Row: row 1 in this example
    'Dim LastCol As Integer
    'With ActiveSheet
     '   LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    'End With
    'MsgBox LastCol
'End Sub



'Public Function LastRowInOneColumn(col)
    'Find the last used row in a Column: column A in this example
 
    'Dim lastRow As Long
    'With ActiveSheet
   ' lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
  '  End With
'   LastRowInOneColumn = lastRow
'End Function

I should add sometimes the spreadsheet does not have all the tabs that may cause an error....
 
Last edited by a moderator:

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

superfb

Board Regular
Joined
Oct 5, 2011
Messages
121
This code seems to work, but i get a message pop up saying you have large amount of data on clipboard would i like to save - how can i incorrporate this in the code to no, can this code be condensed to run faster?

VBA Code:
Public strFileName As String
Public currentWB As Workbook
Public dataWB As Workbook
Public strCopyRange As String

Sub GetData()
    Dim strWhereToCopy As String
    Dim strStartCellColName As String
    Dim strListSheet As String
    
    strListSheet = "List"
    
    'On Error GoTo ErrH
    Sheets(strListSheet).Select
    Range("B8").Select
    
    'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
    Set currentWB = ActiveWorkbook
    Do While ActiveCell.Value <> ""
        
        strFileName = ActiveCell.Offset(0, 1) '& ActiveCell.Value ' think it adds filpath then filename - can swap i think
        strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
        
        'strWhereToCopy = currentWB.Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
      
        'ActiveCell.Offset(0, 4).Value 'tab
        
      
        'strCopyRange = ActiveCell.Offset(0, 2) & ":" & ActiveCell.Offset(0, 3) 'starts at b2 - links to col d and e
        
        
        Application.Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True
        
        Set dataWB = ActiveWorkbook
        strCopyRange = Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
        
        Sheets("All").Activate
    Range("A1").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Range("A5935:G5935").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    
  
    Application.CutCopyMode = False
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Windows("vba-macro-to-copy-data-from-multiple-files2.xlsm").Activate
      strWhereToCopy = currentWB.Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
    Sheets("All").Activate
    ActiveSheet.Paste

        
        'Columns("A:G").Select
        'Selection.Copy
        
        'Range(strCopyRange).Select
        'Selection.Copy
        
          'Windows("vba-macro-to-copy-data-from-multiple-files2.xlsm").Activate
        'Sheets(strWhereToCopy).Select
        'strWhereToCopy = currentWB.Sheets(Array("All", "Male", "Female", "Full-Time", "Part-Time", "Male Full-Time", _
        "Male Part-Time", "Female Full-Time", "Female Part-Time")).Select
      
        'lastRow = LastRowInOneColumn(strStartCellColName)
        'Cells(lastRow + 1, 1).Select
        
        
        
        'Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
        'Application.CutCopyMode = False
        dataWB.Close False
        LastCol = LastColInOneRow(strStartCellColName)
        'Cells(LastCol + 1, 1).Select
        
        Sheets(strListSheet).Select
        ActiveCell.Offset(1, 0).Select
    Loop
    Exit Sub
    
'ErrH:
    'MsgBox "It seems some file was missing. The data copy operation is not complete."
    'Exit Sub
End Sub

Public Function LastColInOneRow(col)
    'Find the last used col in a row: column A in this example
 
    Dim LastCol As Long
    
    With ActiveSheet
    Sheets("All").Range("A5").Select
    LastCol = Selection.End(xlToRight).End(xlUp).Offset(-2, 1).Select
 

superfb

Board Regular
Joined
Oct 5, 2011
Messages
121
I just realised, my other obstacle is that the files are zipped! Is there a way i can incorporate this in the code? i
 

Watch MrExcel Video

Forum statistics

Threads
1,129,814
Messages
5,638,493
Members
417,029
Latest member
lingx86

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