Subscript out of range Error in Copying cell value

Question

I am using this script. I am getting Subscript out of range Error in the line below indicated with the comment

'This is the section to customize, replace with your own action code as needed**

I am trying to copy a cell value E3 present in sheet called One Pager to the sheet in file SUMMARY1.xlsm

I am getting the result but I do get the out of range error. No sure what is happening. The code looks for cell E3 in One Pager instances in multiple files.

The folder path = C:\Users\guhaka\OneDrive - Danone\Documents\Portfolio Optimization\rTAM Presentation\Dossier\

Sub Something() '‹~~ Added this to indent the code. Please change to real name
    Dim fName As String, fPath As String, fPathDone As String
    Dim LR As Long, NR As Long
    Dim wbData As Workbook, wsMaster As Worksheet

    'Setup
    Application.ScreenUpdating = False 'speed up macro execution
    Application.EnableEvents = False 'turn off other macros for now
    Application.DisplayAlerts = False 'turn off system messages for now

    Set wsMaster = ThisWorkbook.Sheets("Master") 'sheet report is built into

    With wsMaster
        If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
            Cells.Select
            Selection.UnMerge
            .UsedRange.Offset(1).EntireRow.Clear
            NR = 2
        Else
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
        End If

        'Path and filename (edit this section to suit)
        fPath = "C:\Users\guhaka\OneDrive - Danone\Documents\Portfolio Optimization\rTAM Presentation\Dossier\" 'remember final \ in this string
        fPathDone = fPath & "Imported\" 'remember final \ in this string
        On Error Resume Next
        MkDir fPathDone 'creates the completed folder if missing
        On Error GoTo 0
        fName = Dir(fPath & "*.xlsm*") 'listing of desired files, edit filter as desired

        'Import a sheet from found files
        Do While Len(fName) > 0
            If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
                Set wbData = Workbooks.Open(fPath & fName) 'Open file

                'This is the section to customize, replace with your own action code as needed

                Sheets("One Pager").Range("E3").Copy
                wbData.Close False 'close file
                Workbooks("SUMMARY1.xlsm").Activate
                ActiveSheet.Range("E3").Select
                ActiveSheet.Paste
                Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
                fName = Dir 'ready next filename
            End If
        Loop
    End With

ErrorExit:     'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True 'turn system alerts back on
    Application.EnableEvents = True 'turn other macros back on
    Application.ScreenUpdating = True 'refreshes the screen
End Sub

Does it work if you qualify the sheet with the workbook it's in? (like this) : wbData.Sheets("One Pager").Range("E3").Copy - If you do not qualify the sheet, it assumes that One Pager is the name of a sheet in the active workbook. You can add this right before that line to see what the active workbook is: Debug.Print ActiveWorkbook.Name — braX
Aren't you always overwriting the pasted value from the previous file? — Tim Williams
Hi @Tim! You are right. Its getting replaced with the value in the last file. How to retain all the values and not overwrite? Should I add an iteration loop? — Kaushik Guha
Hi @braX Thanks! Its working. I just need to capture all the values now and seems like its getting over written — Kaushik Guha

Tim Williams Tim Williams · Accepted Answer · 2021-01-25T16:21:25

Here's how to avoid the overwrite:

 '...
 '...
 'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally

            Set wbData = Workbooks.Open(fPath & fName) 'Open file

            'copy E3 to the next empty cell on the summary sheet
            '  (adjust sheet/workbook as needed)
            wbData.Sheets("One Pager").Range("E3").Copy _
                ThisWorkbook.Sheets("Summary").cells(Rows.Count, "E").End(xlUp).offset(1, 0)

            wbData.Close False 'close file
            Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder

            fName = Dir 'ready next filename
        End If
    Loop
    '...
    '...

Subscript out of range Error in Copying cell value

1 Answers