Extracting multiple cells from different workbooks to a master workbook

[miniproject]

hi there,

I have read through several threads on the use of macro to assist in extracting data from different workbook to a master file. But I can't seem to find a solution that is able to assist me.

I have a total of 100 files where I will like to extract selected cells from individual file and have the extracted data to be input into my master workbook (in a single worksheet) under the correct headers created.

Each of the 100 files are identical in format.I will like to extract the data from cell C4, C5 and C29 from each of these files. The extracted data has to be input into the correct header (column) - i.e. B, C, D respectively i.e Data in C4 of the 100 files ---> input in column B of master workbook and so on. Each extracted data should appear in individual cell in my master workbook.

In addition, I will like to extract the file name of which the data is retrieved to be input in column A in my master workbook.

Will you be able to advise how should I write the code for the above?

Thanks.

 

[al_b_cnu]

Hi Welcome to the board!

Will all the input w/books be in the same folder?
Will you want to append the data or start afresh for each run of the macro?

 

[miniproject]

all the workbooks are in the same folder. They can run in the same macro.

 

[al_b_cnu]

Option Explicit
Const msSourceCells As String = "C4,C5,C29"
Sub ExtractData()
Dim iPtr As Integer
Dim lRow As Long
Dim sPath As String, saSourceCells() As String
Dim sThisWBName As String
Dim vFileList As Variant, vFile As Variant, vResult() As Variant
Dim wbCurrent As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet

sThisWBName = LCase$(ThisWorkbook.Name)

sPath = BrowseForFolder()
vFileList = GetFileList(sPath & Application.PathSeparator & "*.xls")
If IsArray(vFileList) Then

    Set wsTarget = ThisWorkbook.Sheets(1)
    
    saSourceCells = Split(",," & msSourceCells, ",")
    ReDim vResult(1 To 1, 1 To UBound(saSourceCells))
    With ThisWorkbook.Sheets(1)
        lRow = .UsedRange.Row + .UsedRange.Rows.Count
        .Range("A2:" & .Cells(lRow, UBound(vResult, 2)).Address).ClearContents
    End With
    
    Application.EnableEvents = False
    lRow = 1
    For Each vFile In vFileList
        If LCase$(vFile) <> sThisWBName Then
            Set wbCurrent = Nothing
            On Error Resume Next
            Set wbCurrent = Workbooks.Open(FileName:=sPath & Application.PathSeparator & vFile, ReadOnly:=True)
            If Err.Number <> 0 Then
                MsgBox prompt:=vFile & vbCrLf & Err.Description, _
                        Buttons:=vbOKOnly + vbExclamation, _
                        Title:="Unable to Open file"
            End If
            On Error GoTo 0
            If Not (wbCurrent Is Nothing) Then
                vResult(1, 1) = vFile
                Set wsSource = wbCurrent.Sheets(1)
                With wsSource
                    For iPtr = 2 To UBound(saSourceCells)
                        vResult(1, iPtr) = .Range(saSourceCells(iPtr)).Value
                    Next iPtr
                End With
                
                lRow = lRow + 1
                With wsTarget
                    .Range("A" & lRow, Cells(lRow, UBound(vResult, 2)).Address).Value = vResult
                End With
                
                On Error Resume Next
                Application.DisplayAlerts = False
                wbCurrent.Close savechanges:=False
                Application.DisplayAlerts = True
            End If
        End If
    Next vFile
    Application.EnableEvents = True
End If
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

 

[miniproject]

Thanks al_b_cnu ! You have been a great help..!

Just wondering if I were to extract data from other sheets of the 100 files, which part of the code should I amend?

 

[al_b_cnu]

Hi,

You'd have to amend this statement:

 Set wsSource = wbCurrent.Sheets(1)

But you'd probably have to also incorporate some extra error checking

 

[miniproject]

Thanks for the prompt reply.

Will you be able to advise what type of error checking we need to include?

 

[al_b_cnu]

Hi,

Try this (untested) code.

Change the constant 'msSourceSheetName' as appropriate:

Option Explicit

Option Explicit
Const msSourceCells As String = "C4,C5,C29"
Const msSourceSheetName As String = "Sheet1"
Sub ExtractData()
Dim iPtr As Integer
Dim lRow As Long
Dim sPath As String, saSourceCells() As String
Dim sThisWBName As String
Dim sErrorMessage As String
Dim vFileList As Variant, vFile As Variant, vResult() As Variant
Dim wbCurrent As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet

sThisWBName = LCase$(ThisWorkbook.Name)

sPath = BrowseForFolder()
vFileList = GetFileList(sPath & Application.PathSeparator & "*.xls")
If IsArray(vFileList) Then

    Set wsTarget = ThisWorkbook.Sheets(1)
    
    saSourceCells = Split(",," & msSourceCells, ",")
    ReDim vResult(1 To 1, 1 To UBound(saSourceCells))
    With ThisWorkbook.Sheets(1)
        lRow = .UsedRange.Row + .UsedRange.Rows.Count
        .Range("A2:" & .Cells(lRow, UBound(vResult, 2)).Address).ClearContents
    End With
    
    Application.EnableEvents = False
    lRow = 1
    For Each vFile In vFileList
        If LCase$(vFile) <> sThisWBName Then
            Set wbCurrent = Nothing
            On Error Resume Next
            Set wbCurrent = Workbooks.Open(FileName:=sPath & Application.PathSeparator & vFile, ReadOnly:=True)
            If Err.Number <> 0 Then
                MsgBox prompt:=vFile & vbCrLf & Err.Description, _
                        Buttons:=vbOKOnly + vbExclamation, _
                        Title:="Unable to Open file"
            End If
            On Error GoTo 0
            If Not (wbCurrent Is Nothing) Then
                vResult(1, 1) = vFile
                Set wsSource = Nothing
                On Error Resume Next
                Set wsSource = wbCurrent.Sheets(1)
                On Error GoTo 0
                If wsSource Is Nothing Then
                    MsgBox prompt:="Unable to access sheet'" & msSourceSheetName & "' in file '" & vFile, _
                            Buttons:=vbOKOnly + vbExclamation
                Else
                    With wsSource
                        For iPtr = 2 To UBound(saSourceCells)
                            vResult(1, iPtr) = .Range(saSourceCells(iPtr)).Value
                        Next iPtr
                    End With
                    
                    lRow = lRow + 1
                    With wsTarget
                        .Range("A" & lRow, Cells(lRow, UBound(vResult, 2)).Address).Value = vResult
                    End With
                End If
                
                On Error Resume Next
                Application.DisplayAlerts = False
                wbCurrent.Close savechanges:=False
                Application.DisplayAlerts = True
            End If
        End If
    Next vFile
    Application.EnableEvents = True
End If
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

 

[miniproject]

thanks so much..!

will try it out...

 

[jeetusaini85]

Option Explicit
Const msSourceCells As String = "C4,C5,C29"
Sub ExtractData()
Dim iPtr As Integer
Dim lRow As Long
Dim sPath As String, saSourceCells() As String
Dim sThisWBName As String
Dim vFileList As Variant, vFile As Variant, vResult() As Variant
Dim wbCurrent As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet

sThisWBName = LCase$(ThisWorkbook.Name)

sPath = BrowseForFolder()
vFileList = GetFileList(sPath & Application.PathSeparator & "*.xls")
If IsArray(vFileList) Then

    Set wsTarget = ThisWorkbook.Sheets(1)
    
    saSourceCells = Split(",," & msSourceCells, ",")
    ReDim vResult(1 To 1, 1 To UBound(saSourceCells))
    With ThisWorkbook.Sheets(1)
        lRow = .UsedRange.Row + .UsedRange.Rows.Count
        .Range("A2:" & .Cells(lRow, UBound(vResult, 2)).Address).ClearContents
    End With
    
    Application.EnableEvents = False
    lRow = 1
    For Each vFile In vFileList
        If LCase$(vFile) <> sThisWBName Then
            Set wbCurrent = Nothing
            On Error Resume Next
            Set wbCurrent = Workbooks.Open(FileName:=sPath & Application.PathSeparator & vFile, ReadOnly:=True)
            If Err.Number <> 0 Then
                MsgBox prompt:=vFile & vbCrLf & Err.Description, _
                        Buttons:=vbOKOnly + vbExclamation, _
                        Title:="Unable to Open file"
            End If
            On Error GoTo 0
            If Not (wbCurrent Is Nothing) Then
                vResult(1, 1) = vFile
                Set wsSource = wbCurrent.Sheets(1)
                With wsSource
                    For iPtr = 2 To UBound(saSourceCells)
                        vResult(1, iPtr) = .Range(saSourceCells(iPtr)).Value
                    Next iPtr
                End With
                
                lRow = lRow + 1
                With wsTarget
                    .Range("A" & lRow, Cells(lRow, UBound(vResult, 2)).Address).Value = vResult
                End With
                
                On Error Resume Next
                Application.DisplayAlerts = False
                wbCurrent.Close savechanges:=False
                Application.DisplayAlerts = True
            End If
        End If
    Next vFile
    Application.EnableEvents = True
End If
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

Hi Alan,

This code is very useful, i need a little help on this code that i don't want to use file name in column "A" when i run this macro. Which part of this code i should delete.

Thanks in advance,
Jeetu