VBA to copy specific cells from all files in a folder

Hi Mehul,

The problem is that in your code (by design) a single apostrophe denotes a the start or end of a field. To get around this you to write code to replace any single apostrophe in the fn filename variable with two apostrophes, which though I can't test without being on your server, I would use something like this...

If InStr(fn, "'") > 0 Then
            fn = fn & Replace(fn, "'", "''")
        End If

...just below this line:

i = i + 1

HTH

Robert

Is it possible to program the code to look in Sheet2 if "Hours" worksheet is not present?

Though it's much easier to do this while the file is open, try these lines of code...

If IsError(ThisWorkbook.Sheets(1).Cells(i, 1)) = True Then
        myFormula = "='" & myDir & "[" & fn & "]Sheet2'!"
        .Value = fn
    End If

...immediately under this existing line:

.Value = fn

Regards,

Robert

Without being on your server and testing it's very hard to recommend a solution, but see how this goes:

    With ThisWorkbook.Sheets(1).Cells(i, 1)
        On Error Resume Next
            .Value = fn
            If IsError(ThisWorkbook.Sheets(1).Cells(i, 1)) = True Then
                myFormula = "='" & myDir & "[" & fn & "]Sheet2'!"
                .Value = fn
            End If
        On Error GoTo 0
        .Offset(, 1).Resize(, 2).Formula = _
        Array(myFormula & "C4", myFormula & "O17")
    End With

Robert

Not sure if this will help, here is a screenshot of the point where excel asks me to select a sheet as it couldn't find Hours sheet. Hope it helps.

No it doesn't as the attachment doesn't open

OK, that really doesn't help either but try this where I use an ADO connection to the workbook to determine if the sheet exists or not:

Option Explicit
Sub test()

    '//As this macro uses early binding, a reference to 'Microsoft ActiveX Data Objects n.n library' (via Tools > References menu item) is required//

    Dim myDir As String, fn As String, i As Long, myFormula As String
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim strClosedWBSheetName As String
    
    myDir = "\\STM-FS2\shared documents\shared documents\JOB COSTINGS\"
    fn = Dir(myDir & "*.xlsx")    
    
    strClosedWBSheetName = "HOURS"
    
    Do While fn <> ""
        i = i + 1
        
        If InStr(fn, "'") > 0 Then
            fn = Replace(fn, "'", "''")
        End If
        
        'Create a connection to the closed workbook
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
             "Data Source=" & myDir & fn & ";" & _
             "Extended Properties=""Excel 8.0;HDR=Yes;"";"
        
        On Error Resume Next
            'If the tab 'strClosedWBSheetName' string variable exists in the workbook, then...
            rst.Open "SELECT * FROM [" & strClosedWBSheetName & "$];", cnn, adOpenStatic, adLockReadOnly
            If Err.Number = 0 Then
                '...set the 'myFormula' string variable with it
                myFormula = "='" & myDir & "[" & fn & "]" & strClosedWBSheetName & "'!"
            'Else...
            Else
                '...set the 'myFormula' string variable with 'Sheet2'
                myFormula = "='" & myDir & "[" & fn & "]Sheet2'!"
            End If
        On Error GoTo 0
        
        'Remove recordset and connecttion from memory
        Set rst = Nothing
        cnn.Close
                
        With ThisWorkbook.Sheets(1).Cells(i, 1)
            .Value = fn
            .Offset(, 1).Resize(, 2).Formula = _
            Array(myFormula & "C4", myFormula & "O17")
        End With
        fn = Dir
        
    Loop
    
End Sub

Again this is untested so it may need some tweaking on your side. Also note the comment regarding making a reference to the Microsoft ActiveX Data Objects library which is required before you try and run the macro.

Regards,

Robert