Reading data from closed workbooks (VBA)

R

RobFaas

New Member
Joined
Jul 5, 2011
Messages
4
Hi all,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
first off, I’m a complete beginner in VBA so sorry for asking probably a dumb question.<o:p></o:p>
<o:p></o:p>
I'm currently working on a macro that can read data from closed workbooks in a folder (specified cells on a sheet) and copy the value to the workbook that is open. I have searched the internet and this forum and found some code that is working. (see below) but..<o:p></o:p>
<o:p></o:p>
The code below works, however I want to modify it that when the macro finds a workbook without the designated sheet ("toetsing erosiebestendigheid") it just skips the file. I guess this goes with an IF statement somewhere I just can't figure out where to put it and get it working..<o:p></o:p>
<o:p></o:p>
The code below is also pretty slow. Do any of you guy's now a routine that is faster with the same result?<o:p></o:p>
Code: 
Sub ReadDataFromAllWorkbooksInFolder()
Dim FolderName As String, wbName As String, r As Long
Dim wbList() As String, wbCount As Integer, i As Integer
Dim monsternr As Variant, monsterdiep As Variant, vloeigrens As Variant, plastic As Variant
Dim mineraledelen As Variant, resultaat As Variant
 
    FolderName = ActiveWorkbook.Path
    ' create list of workbooks in foldername
    wbCount = 0
    wbName = Dir(FolderName & "\" & "*.xls")
    While wbName <> vbNullString
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = wbName
        wbName = Dir
    Wend
    If wbCount = 0 Then Exit Sub
    ' get values from each workbook
    r = 0
    'Workbooks.Add
    For i = 1 To wbCount
        r = r + 1
        monsternr = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F7")
        monsterdiep = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F11")
        vloeigrens = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F21")
        plastic = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F22")
        mineraledelen = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F23")
        resultaat = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F25")
        Cells(r, 1).Formula = monsternr
        Cells(r, 2).Formula = monsterdiep
        Cells(r, 3).Formula = vloeigrens
        Cells(r, 4).Formula = plastic
        Cells(r, 5).Formula = mineraledelen
        Cells(r, 6).Formula = resultaat
    Next i
End Sub
Private Function GetInfoFromClosedFile(ByVal wbPath As String, wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
    GetInfoFromClosedFile = vbNullString
    If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
    If Dir(wbPath & wbName) = vbNullString Then Exit Function
    arg = "'" & wbPath & "[" & wbName & "]" & wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub

hope someone can help!

thanks!
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Try this. Didn't test.
Code: 
[COLOR="Blue"]Private[/COLOR] wbPath [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]String[/COLOR]
[COLOR="Blue"]Const[/COLOR] wsName [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]String[/COLOR] = "Toetsing erosiebestendigheid"

[COLOR="Blue"]Sub[/COLOR] ReadDataFromAllWorkbooksInFolder()
    
    [COLOR="Blue"]Dim[/COLOR] wbName [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]String[/COLOR], r [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Long[/COLOR]
    [COLOR="Blue"]Dim[/COLOR] arr [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Variant[/COLOR]
        
    [COLOR="Blue"]Dim[/COLOR] fso [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Object[/COLOR], aFile [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Object[/COLOR]
    
    [COLOR="Blue"]Set[/COLOR] fso = CreateObject("Scripting.FileSystemObject")
    wbPath = ActiveWorkbook.Path
    
    [COLOR="Blue"]For[/COLOR] [COLOR="Blue"]Each[/COLOR] aFile [COLOR="Blue"]In[/COLOR] fso.GetFolder(ThisWorkbook.Path).Files
        [COLOR="Blue"]If[/COLOR] fso.GetExtensionName(aFile.Name) [COLOR="Blue"]Like[/COLOR] "[Xx][Ll][Ss]*" [COLOR="Blue"]Then[/COLOR]
            arr = GetInfoFromClosedFile(aFile.Name)
            r = r + 1
            Cells(r, 1).Formula = arr(1)
            Cells(r, 2).Formula = arr(2)
            Cells(r, 3).Formula = arr(3)
            Cells(r, 4).Formula = arr(4)
            Cells(r, 5).Formula = arr(5)
            Cells(r, 6).Formula = arr(6)
        [COLOR="Blue"]End[/COLOR] [COLOR="Blue"]If[/COLOR]
    [COLOR="Blue"]Next[/COLOR]

[COLOR="Blue"]End[/COLOR] [COLOR="Blue"]Sub[/COLOR]

[COLOR="Blue"]Private[/COLOR] [COLOR="Blue"]Function[/COLOR] GetInfoFromClosedFile(wbName [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]String[/COLOR]) [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Variant[/COLOR]()
    [COLOR="Blue"]Dim[/COLOR] info(1 [COLOR="Blue"]To[/COLOR] 6)  [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Variant[/COLOR], arrRefs [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Variant[/COLOR], i [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Integer[/COLOR], arg [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]String[/COLOR]
    arrRefs = Array("F7", "F11", "F21", "F22", "F23", "F25")
    [COLOR="Blue"]For[/COLOR] i = 1 [COLOR="Blue"]To[/COLOR] 6
        arg = "'" & wbPath & "[" & wbName & "]" & wsName & "'!" & Range(arrRefs(i)).Address([COLOR="Blue"]True[/COLOR], [COLOR="Blue"]True[/COLOR], xlR1C1)
        [COLOR="Blue"]On[/COLOR] [COLOR="Blue"]Error[/COLOR] [COLOR="Blue"]Resume[/COLOR] [COLOR="Blue"]Next[/COLOR]
        info(i) = ExecuteExcel4Macro(arg)
        [COLOR="Blue"]On[/COLOR] [COLOR="Blue"]Error[/COLOR] [COLOR="Blue"]GoTo[/COLOR] 0
    [COLOR="Blue"]Next[/COLOR]
    GetInfoFromClosedFile = info
[COLOR="Blue"]End[/COLOR] [COLOR="Blue"]Function[/COLOR]
 
Last edited:
Upvote 0
Hi Sektor,

Thanks for the quick reply! the code looks good.. unfortunatly it does not work.

the macro seems to crash at:
Code: 
Dim fso As New FileSystemObject, aFile As File
.

since i don't really know what goes on in that statement i have no idea how to fix it...

hope you can help me out here.
 
Upvote 0
You didn't see correction. Take a look at code once again.
 
Upvote 0
Hi Sektor,

you are right, i did not see the corrected code. thanks for that.

The new code does not crash, but does not work either. When i run the code, i get a pop-up to select a file, and i can open a file. After opening like 4 files, the macro shutsdown with an error saying "subscript out of range".The macro has added nothing on the active axcel sheet either..

could you help me on this?

many thanks!
 
Upvote 0
Hi Andrew,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
yes, i saw what you posted and looked at the code.<o:p></o:p>
<o:p></o:p>
since i'm a complete newbie however to VBA i can't figure out how to incorporate that code with the existing code to retrieve data from those files..<o:p></o:p>
 
Upvote 0
Try the untested:

Code: 
Sub ReadDataFromAllWorkbooksInFolder()
    Dim FolderName As String, wbName As String, r As Long
    Dim wbList() As String, wbCount As Integer, i As Integer
    Dim monsternr As Variant, monsterdiep As Variant, vloeigrens As Variant, plastic As Variant
    Dim mineraledelen As Variant, resultaat As Variant
    Dim Col As Collection, Book As String, j As Long
    FolderName = ActiveWorkbook.Path
    ' create list of workbooks in foldername
    wbCount = 0
    wbName = Dir(FolderName & "\" & "*.xls")
    While wbName <> vbNullString
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = wbName
        wbName = Dir
    Wend
    If wbCount = 0 Then Exit Sub
    ' get values from each workbook
    r = 0
    'Workbooks.Add
    For i = 1 To wbCount
        Book = FolderName & "\" & wbList(i)
        Set Col = GetSheetsNames(Book)
        For j = 1 To Col.Count
            If Col(j) = "Toetsing erosiebestendigheid" Then
                r = r + 1
                monsternr = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F7")
                monsterdiep = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F11")
                vloeigrens = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F21")
                plastic = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F22")
                mineraledelen = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F23")
                resultaat = GetInfoFromClosedFile(FolderName, wbList(i), "Toetsing erosiebestendigheid", "F25")
                Cells(r, 1).Formula = monsternr
                Cells(r, 2).Formula = monsterdiep
                Cells(r, 3).Formula = vloeigrens
                Cells(r, 4).Formula = plastic
                Cells(r, 5).Formula = mineraledelen
                Cells(r, 6).Formula = resultaat
                Exit For
            End If
        Next j
    Next i
End Sub

You will need to add Juan Pablo's function:

Code: 
Function GetSheetsNames(wbName As String) As Collection
'Needs a reference to:
'Microsoft ActiveX Data Object X.X Library
'Microsoft ADO Ext. X.X for DLL and Security
    Dim objConn As ADODB.Connection
    Dim objCat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim sConnString As String
    Dim sSheet As String
    Dim Col As New Collection
    sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & wbName & ";" & _
        "Extended Properties=Excel 8.0;"
    Set objConn = New ADODB.Connection
    objConn.Open sConnString
    Set objCat = New ADOX.Catalog
    Set objCat.ActiveConnection = objConn
    For Each tbl In objCat.Tables
        sSheet = tbl.Name
        sSheet = Application.Substitute(sSheet, "'", "")
        sSheet = Left(sSheet, InStr(1, sSheet, "$", 1) - 1)
        On Error Resume Next
        Col.Add sSheet, sSheet
        On Error GoTo 0
    Next tbl
    Set GetSheetsNames = Col
    objConn.Close
    Set objCat = Nothing
    Set objConn = Nothing
End Function

and set the mentioned references.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
EXCEL VBA - help to copy filtered data from one workbook to multiple new workbooks and save code.
Replies
2
Views
440
Jordan2
J
D
  • Question Question
Create running data table from daily table updates in another closed workbook
Replies
1
Views
689
ddander54
D
O
  • Solved
Copy from workbook and dynamically filldown data
Replies
3
Views
764
Alex Blakenburg
A
M
  • Question Question
VBA Import Data from Multiple Folders
Replies
1
Views
2K
John_w
J
C
  • Question Question
Error help - Get data from a closed workbook (without opening)
Replies
7
Views
2K
GWteB
GWteB

Forum statistics

Threads
1,224,583
Messages
6,179,678
Members
452,937
Latest member
Bhg1984

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top