VBA Paste Special and finding the next empty row

[Roybzer]

I'm trying to create a master spreadsheet that collates worker timesheets from 100+ workers, onto a single master spreadsheet(pasted to 1 sheet, not to separate sheets).

I've managed to get it to the point(with a jigsaw of borrowed code), where the timesheets do paste in to the one master sheet, however, it is doing so with formulas, resulting in errors everywhere.

Also, I'm using a crude counter to increment count to create a new row number to start the next paste.

Is there a way to change the below to paste values, and to start the next paste from the next blank row?

Public Sub ImportActiveList()
Dim FileNames As Variant
Dim FileName As Variant
Dim masterTS As Worksheet
Dim ActiveTS As Workbook
Dim count As Integer

Set masterTS = ActiveWorkbook.Sheets("Sheet1")

FileNames = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select Active List to Import", _
MultiSelect:=True)
If VarType(FileNames) = vbBoolean Then
If Not FileNames Then Exit Sub
End If
count = 1

For Each FileName In FileNames
Set ActiveTS = Workbooks.Open(FileName)
ActiveTS.Sheets("Timesheet").UsedRange.Copy masterTS.Range("A" & count)
ActiveTS.Close False
count = count + 100
Next FileName
End Sub

 

[JackDanIce]

Try:

Public Sub ImportActiveList_1()

    Dim FileNames   As Variant
    Dim arr()       As Variant
    Dim x           As Long
    Dim wkb         As Workbook
    
    With Application
        FileNames = .GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Select Active List to Import", , True)
        If VarType(FileNames) = vbBoolean Or Not FileNames Then Exit Sub
        .ScreenUpdating = False
    End With
    
    For x = LBound(FileNames) To UBound(FileNames)
        Set wkb = Workbooks.Open(FileNames(x), ReadOnly:=True)
        With wkb
            arr = .Sheets("Timesheet").UsedRange.Value
            .Close False
        End With
        Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Set wkb = Nothing
        Erase arr
    Next x
    
    With Sheets("Sheet1")
        If .Cells(1, 1).End(xlToRight).column = .Cells.Columns.count Then .Cells(1, 1).EntireRow.Delete
    End With
    
    Application.ScreenUpdating = True
    
End Sub

 

[Roybzer]

Thanks JackDanIce,

It's throwing a type mismatch error with the validation of FileNames file type, and I'm not sure why:

If VarType(FileNames) = vbBoolean Or Not FileNames Then Exit Sub

 

[JackDanIce]

Try:

Public Sub ImportActiveList_1()


    Dim FileNames   As Variant
    Dim arr()       As Variant
    Dim x           As Long
    Dim wkb         As Workbook
        
    FileNames = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Select Active List to Import", , True)
    If VarType(FileNames) = vbBoolean Or Not FileNames Then Exit Sub
        
    Application.ScreenUpdating = False
        
    For x = LBound(FileNames) To UBound(FileNames)
        Set wkb = Workbooks.Open(FileNames(x), ReadOnly:=True)
        With wkb
            arr = .Sheets("Timesheet").UsedRange.Value
            .Close False
        End With
        Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Set wkb = Nothing
        Erase arr
    Next x
    
    With Sheets("Sheet1")
        If .Cells(1, 1).End(xlToRight).column = .Cells.Columns.count Then .Cells(1, 1).EntireRow.Delete
    End With
    
    Application.ScreenUpdating = True
    
End Sub