Macro to open files in a folder, copy data if there is a match, close them

[sgeng4]

Hi all,

I'm looking for some help making a macro.

I have a bunch of files in a folder. I want a macro that opens up each file one by one, and if the names match, then copy the value, date and certificate associated with that name onto the master spreadsheet.


So in the folder, I have excel files that have the following information in each sheet in the second tab:


[table="width: 500", class: grid"]
[tr]
[td]Certificate[/td]
[td]A8[/td]
[/tr]
[tr]
[td]date[/td]
[td]Dec 9[/td]
[/tr]
[tr]
[td]name2[/td]
[td]1.3[/td]
[/tr]
[tr]
[td]name3[/td]
[td]1.5[/td]
[/tr]
[tr]
[td]name6[/td]
[td]3.0[/td]
[/tr]
[/table]

In the master sheet, I have the following columns:
[table="width: 500, class: grid"]
[tr]
[td]UNIQUENAME[/td]
[td]VALUE[/td]
[td]DATE[/td]
[td]CERTIFICATE[/td]
[/tr]
[tr]
[td]name1[/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td]name2[/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td]name3[/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[/table]

I am looking for a way for excel to automatically fill in the value, date, and certificate numbers by looking them up in the sheets and pasting them into the correct row. For example, like so:




[table="width: 500, class: grid"]
[tr]
[td]UNIQUENAME[/td]
[td]VALUE[/td]
[td]DATE[/td]
[td]CERTIFICATE[/td]
[/tr]
[tr]
[td]name1[/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td]name2[/td]
[td]1.3[/td]
[td]Dec 9[/td]
[td]A8[/td]
[/tr]
[tr]
[td]name3[/td]
[td]1.5[/td]
[td]Dec 9[/td]
[td]A8[/td]
[/tr]
[/table]



So far, I got the macro to open the file folder, and open the files one by one, but I don't know how to code it so it searches for matches, and copies the correct cells over.

Sub CompleteMasterSpreadsheet()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim FileName As String
Dim Path As String


With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1) & "\"
End With

FileName = Dir(Path & "*.xls*")

'Loop to open excel files

 Do While Len(FileName) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(Path & FileName)
    '
    ' CODE to search for matches, copy them if there is a match
    '

    
    ' end of code

     
    wbk.Close True
    FileName = Dir
Loop
End Sub

Help is really appreciated!

Thank you. =)

 

[Fluff]

Untested but try

Sub CompleteMasterSpreadsheet()
   'DECLARE AND SET VARIABLES
   Dim wbk As Workbook
   Dim Sht As Worksheet
   Dim FileName As String
   Dim Path As String
   Dim Cl As Range
   Dim Rng As Range
   
   With Application.FileDialog(4)
       .Show
       Path = .SelectedItems(1) & "\"
   End With
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl
      Next Cl
      
      FileName = Dir(Path & "*.xls*")
      
      'Loop to open excel files
       Do While Len(FileName) > 0  'IF NEXT FILE EXISTS THEN
         Set wbk = Workbooks.Open(Path & FileName)
         Set Sht = wbk.Sheets(2)
         For Each Rng In Sht.Range("A3", Sht.Range("A" & Rows.Count).End(xlUp))
            If .exists(Rng.Value) Then
               .Item(Rng.Value).Offset(, 1).Value = Rng.Offset(, 1).Value
               .Item(Rng.Value).Offset(, 2).Value = Sht.Range("A2").Value
               .Item(Rng.Value).Offset(, 3).Value = Sht.Range("B1").Value
            End If
         Next Rng
         wbk.Close True
         FileName = Dir
      Loop
   End With
End Sub

As you haven't said where the data is, I've assumed that it starts in A1

 

[sgeng4]

Thank you very much Fluff.

The date is in sheet1 of the workbook, cell C7 -> Goes to column K in master sheet
The certificate is in Sheet1 of the workbook, cell F7 -> Goes to column J in master sheet
The names are in sheet 2, column B -> Goes to column A in master sheet
The values are in sheet 2, column G -> Goes to column F in master sheet

Assume there are over 50 names and values per workbook that opens.

I'm trying to make your code work right now, but I don't understand all those commands and functions.

 

[Fluff]

OK, try this

Sub CompleteMasterSpreadsheet()
   'DECLARE AND SET VARIABLES
   Dim wbk As Workbook
   Dim Sht As Worksheet
   Dim FileName As String
   Dim Path As String
   Dim Cl As Range
   Dim Rng As Range
   
   With Application.FileDialog(4)
       .Show
       Path = .SelectedItems(1) & "\"
   End With
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp)) [COLOR=#008080]'<< Looks in col A of the master sheet for the names[/COLOR]
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl [COLOR=#008080]'<< Adds the names to a dictionary[/COLOR]
      Next Cl
      
      FileName = Dir(Path & "*.xls*")
      
       Do While Len(FileName) > 0
         Set wbk = Workbooks.Open(Path & FileName)
         Set Sht = wbk.Sheets(2)
         For Each Rng In Sht.Range("B2", Sht.Range("B" & Rows.Count).End(xlUp))[COLOR=#008080] '<< Looks in col B of the new wbk for the names[/COLOR]
            If .exists(Rng.Value) Then [COLOR=#008080]'<< checks if the name is in the dictionary (ie in the Master sheet)[/COLOR]
               .Item(Rng.Value).Offset(, 5).Value = Rng.Offset(, 6).Value            [COLOR=#008080]  '<< adds the value to the master[/COLOR]
               .Item(Rng.Value).Offset(, 10).Value = wbk.Sheets(1).Range("C7").Value  [COLOR=#008080] '<< adds the date to the master[/COLOR]
               .Item(Rng.Value).Offset(, 9).Value = wbk.Sheets(1).Range("F7").Value   [COLOR=#008080] '<< add the certificate to the master[/COLOR]
            End If
         Next Rng
         wbk.Close False
         FileName = Dir
      Loop
   End With
End Sub

 

[sgeng4]

Thanks again!

No it isn't working. The files definitely open and close, but the values in the cells aren't being added.

 

[Fluff]

Is the master sheet active when you run the macro?
Do you have names in the master sheet from A2 downwards?

 

[sgeng4]

I've attached an image to show you what it looks like exactly. The master sheet is active, and the names do go down.

 

[Fluff]

Ok, how about this, I've changed the sheet index to sheet names & corrected one of the offsets

Sub CompleteMasterSpreadsheet()
   'DECLARE AND SET VARIABLES
   Dim wbk As Workbook
   Dim Sht As Worksheet
   Dim FileName As String
   Dim Path As String
   Dim Cl As Range
   Dim Rng As Range
   
   With Application.FileDialog(4)
       .Show
       Path = .SelectedItems(1) & "\"
   End With
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp)) '<< Looks in col A of the master sheet for the names
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl '<< Adds the names to a dictionary
      Next Cl
      
      FileName = Dir(Path & "*.xls*")
      
       Do While Len(FileName) > 0
         Set wbk = Workbooks.Open(Path & FileName)
         Set Sht = wbk.Sheets("Values")
         For Each Rng In Sht.Range("B2", Sht.Range("B" & Rows.Count).End(xlUp)) '<< Looks in col B of the new wbk for the names
            If .exists(Rng.Value) Then '<< checks if the name is in the dictionary (ie in the Master sheet)
               .Item(Rng.Value).Offset(, 5).Value = Rng.Offset(, 5).Value              '<< adds the value to the master
               .Item(Rng.Value).Offset(, 10).Value = wbk.Sheets("info").Range("C7").Value   '<< adds the date to the master
               .Item(Rng.Value).Offset(, 9).Value = wbk.Sheets("info").Range("F7").Value    '<< add the certificate to the master
            End If
         Next Rng
         wbk.Close False
         FileName = Dir
      Loop
   End With
End Sub

 

[sgeng4]

Thanks! I really appreciate your help.

I got an error this time.

"Run-time error '9':
Subscript out of range"

 

[Fluff]

What line of code gave the error?