Unkown Runtime error parsing excel files

[edTech]

Good evening,
I have the following VbScript code that reads multiple excel files and copies all the data and paste it to another workbook. I am getting an unkown runtime error on the .PasteSpecial please help. Error line highlighted in blue.

Option Explicit
Dim Excel, fso, strPathSrc, file, folder, Workbook, NRow, FileName, LastRow, Sheet, DestRange, SourceRange, WshShell, strDesktop, listfile, x, Workbook2, Sheet2, a, LastCol
Dim ArrayList, i

Const xlUp = -4162
Const xlDown = -4121
Const xlToRight = -4161
Const xlPasteValues = -4163
Set fso = CreateObject("Scripting.FileSystemObject")
Set Excel = CreateObject("Excel.Application")
Set WshShell = WScript.CreateObject("WScript.Shell")

strPathSrc = "Z:\"
Set Workbook2 = Excel.Workbooks.Add()
Set Sheet2 = Workbook2.WorkSheets(1)
Set Folder = fso.GetFolder(strPathSrc)

For each file in Folder.SubFolders
For each x in file.Files

If NRow = 0 Then
NRow = 4
End if

FileName = x.path

Set Workbook = Excel.Workbooks.Open(FileName)
Set Sheet = Workbook.WorkSheets(1)


'LastCol = Sheet.Range("A4").End(xlToRight).Column
LastRow = Sheet.Range("A4:H" & Sheet.Rows.Count).End(xlDown).Row

SourceRange = Sheet.Range("A4:H" & LastRow).copy
'Set SourceRange = Sheet.Range("A4", Sheet.Cells(LastRow, LastCol)).copy

Sheet2.Range("A4", SourceRange).PasteSpecial -4163, -4142, True, False

Workbook.Close
Next
Next

Excel.DisplayAlerts = False

Workbook2.SaveAs(strDesktop & "\Effeciency_Merge.xlsx")

MsgBox "Copy Complete"

 

[rlv01]

It's hard to know what you are doing, but perhaps replace this

Sheet2.Range("A4", SourceRange).PasteSpecial -4163, -4142, True, False

With this

Sheet2.Range("A4").PasteSpecial -4163, -4142, True, False

or better yet, this

Sheet2.Range("A4").PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True

Also, when you post code, try to use the code tags (<vba/> button). It makes your code easier to read.

 

[edTech]

Good Morning rlv01 thank you for the input. To explain better i have a directory with subfolders that contain many excel files. What i need to do is read each excel file and copy the data from each one and then copy that data to one workbook. Where i run into issues is because VBA does not translate one-to-one to VbScript in which my code is written to. I have updated the code with your suggestion

     Sheet2.Range("A4").PasteSpecial -4163, -4142, True, False

I am getting an error when opening a file to read as: "Unable to get the Open property of the workbooks class"

Option Explicit

Dim Excel, fso, strPathSrc, file, folder, Workbook, NRow, FileName, LastRow, Sheet, DestRange, SourceRange, WshShell, strDesktop, listfile, x, Workbook2, Sheet2, a, LastCol
Dim ArrayList, i

Const xlUp = -4162
Const xlDown = -4121
Const xlToRight = -4161
Const xlPasteValues = -4163

Set fso = CreateObject("Scripting.FileSystemObject")
Set Excel = CreateObject("Excel.Application")
Set WshShell = WScript.CreateObject("WScript.Shell")

strDesktop = WshShell.SpecialFolders("Desktop")

strPathSrc = "Z:\"

Set Workbook2 = Excel.Workbooks.Add()
Set Sheet2 = Workbook2.WorkSheets(1)
Set Folder = fso.GetFolder(strPathSrc)

For each file in Folder.SubFolders
    For each x in file.Files
    
        If NRow = 0 Then 
            NRow = 4
        End if
        
        FileName = x.path

'Read each file in SubFolders
Set Workbook = Excel.Workbooks.Open(FileName)
Set Sheet = Workbook.WorkSheets(1)

'Determine data range
LastRow = Sheet.Range("A4:H" & Sheet.Rows.Count).End(xlDown).Row
SourceRange = Sheet.Range("A4:H" & LastRow).copy

    Sheet2.Range("A4", SourceRange).PasteSpecial -4163, -4142, True, False

Workbook.Close
    Next
Next
    Excel.DisplayAlerts = False
    
    Workbook2.SaveAs(strDesktop & "\Covid19_Effeciency_Merge.xlsx")
    
    MsgBox "Copy Complete"

 

[rlv01]

I suspect that there is a problem with your file path and so you never assign a valid worksheet object to Worksheet2.

Try this and see if it makes a difference:

Sub Test()
   'Dim Excel, fso, strPathSrc, file, folder, Workbook, NRow, FileName, LastRow, Sheet, DestRange, SourceRange, WshShell, strDesktop, listfile, x, Workbook2, Sheet2, a, LastCol
    Dim FileName As String
    Dim folder As Object, SubF As Object
    Dim fso As Object
    Dim LastRow As Long
    Dim NRow As Long
    Dim Sheet As Worksheet
    Dim Sheet2 As Worksheet
    Dim SourceRange As Range
    Dim strDesktop As String
    Dim strPathSrc As String
    Dim WB As Workbook
    Dim WB2 As Workbook
    Dim WshShell As Object
    Dim xlFile As Object
    Dim FileCnt As Long
    Dim FExt As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set WshShell = CreateObject("WScript.Shell")

    strDesktop = WshShell.SpecialFolders("Desktop")
    strPathSrc = "Z:\"

    If fso.FolderExists(strPathSrc) Then
        Application.ScreenUpdating = False
        Set WB2 = Excel.Workbooks.Add()
        Set Sheet2 = WB2.Worksheets(1)
        Set folder = fso.GetFolder(strPathSrc)
        FileCnt = 0
        If folder.SubFolders.Count > 0 Then
            For Each SubF In folder.SubFolders
                For Each xlFile In SubF.Files
                    FExt = fso.GetExtensionName(xlFile.Path)
                    Select Case FExt
                    Case "xlsx", "xls", "xlsm"
                        FileCnt = FileCnt + 1
                        If NRow = 0 Then
                            NRow = 4
                        End If

                        FileName = xlFile.Path

                        'Read each file in SubFolders
                        Set WB = Excel.Workbooks.Open(FileName)
                        Set Sheet = WB.Worksheets(1)

                        'Determine data range
                        LastRow = Sheet.Range("A4:H" & Sheet.Rows.Count).End(xlDown).Row
                        Set SourceRange = Sheet.Range("A4:H" & LastRow)
                        SourceRange.Copy

                        Sheet2.Range("A4").PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
                        WB.Close False
                    End Select
                    DoEvents
                Next xlFile
            Next SubF

            If FileCnt > 0 Then
                Application.DisplayAlerts = False
                WB2.SaveAs (strDesktop & "\Covid19_Effeciency_Merge.xlsx")
                WB2.Close False
                Application.DisplayAlerts = True
                MsgBox "Copy Complete"
            Else
                MsgBox "No files found", vbExclamation
            End If
        Else
            MsgBox "No Subfolders found", vbExclamation
        End If
    Else
        MsgBox "Path: " & strPathSrc & " not found", vbExclamation
    End If
    Application.ScreenUpdating = True
End Sub