VBA Code help!

[superfb]

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?

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

 

[superfb]

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?

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]

I just realised, my other obstacle is that the files are zipped! Is there a way i can incorporate this in the code? i