Copy various cells from a directory of workbooks

[StuartWhi]

Hello Experts,

I have been trying to get this to work for some time and feel I’m very close.
- I’m a beginner to VBA so by combining several other threads I was able to get this far.

What’s meant to happen,
Prompt user to open a directory and then copy pre-defined cells from each tab (except the “Description” tab) of each file onto a new row in the current excels “Summary” tab.
- Filenames and tab names from the import files can change (people filling in the excel template tend to do this) but the cells remain the same.
The import to (running the macro) file has a “Summary” tab only and is basically blank except some headings,
The import from files has many tabs with the only consentient tab name being the “Description” tab.

The issue I have (I think) is my ActiveWorkbook is not the same as the fn string which is what I would like it to be (it’s the same as ThisWorkbook).
- This courses VBA to prompt the user to select the tab as it’s not able to find the “Description” tab within the excel to copy from (as it’s reading the tab information from ThisWorkbook) (I think).

Any assistance would be greatly appreciated.

Code below,

Sub GetMyData()
Dim myDir As String, fn As String, sn As String, n As Long, NR As Long, WkSht As Worksheet

' myDir runs the above code to allow you open a folder
myDir = GetDirectory("Select a folder containing Excel files you want to merge")

' Set's the Filename "fn" varibles
fn = Dir(myDir & "\*.xls")

Do While fn <> ""
  If fn <> ThisWorkbook.Name Then
    For Each WkSht In ActiveWorkbook.Worksheets         'This is the issue ActiveWorkbook should be fn.
        With ThisWorkbook.Sheets("Summary")
        NR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            If WkSht.Name <> "Description" Then
                With .Range("A" & NR)
                .Formula = "='" & myDir & "\[" & fn & "]" & WkSht.Name & "'!B33"
                .Value = .Value
                End With
'Many repeats of this section.
                With .Range("G" & NR)
                .Formula = "='" & myDir & "\[" & fn & "]" & WkSht.Name & "'!D17"
                .Value = .Value
                .Offset(, 1).Value = fn
                End With
            End If
        End With
    Next
  End If
  fn = Dir
Loop
End Sub

Thanks in advance.

 

[daverunt]

Hi,

the ActiveWorkbook is the workbook that is in focus. As you haven't opened 'fn' then 'ThisWorkbook' is the ActiveWorkbook.

Try the following.

Do While fn <> ""
Workbooks.Open myDir & "\" & fn
Set XLSFile = ActiveWorkbook 
  If fn <> ThisWorkbook.Name Then
 
 
------------ code------------
 
 
XLSFile.Close False
Next

 

[StuartWhi]

Hi Daverunt,

Thank's your a legend.

Works great in first round of testing will test completely tomorrow but it's looking good.

Stuart.