VBA code required

[Marky_B]

Good evening all,
first off thank you for any help, given. I'm after automating invoices from 2 registers.
The setup is I have 2 workbooks [Register_1] and [Register_2] with 5 sheets in each [Week_1] [Week_2] [Week_3] [Week_4] [Week_5], and 1 workbook [Master] with sheet [Invoice] macros enabled to pull data from the other 2 workbooks all saved in the same folder. What I need help with is the following

• I would like code to search [Register_1] sheet [Week_1] for a surname in cell range {A8-A95} and forename cell range {B8-B95} if match found then
  • copy cell {A1} to workbook [Master] sheet [Invoice] cell {B13}
  • copy total for week to workbook [Master] sheet [Invoice] cell {C13}
  • repeat for [Week_2] [Week_3] [Week_4] [Week_5] moving copy down a cell each time in workbook [Master] sheet [Invoice]
  • If no match then end

Hopefully this all makes sense. I wish I could share the project somehow?

Thank you once again for any help

 

[Marky_B]

Ah my mistake, meant to be A2 which is text “Register 1 week 1etc”

thank you for the code

 

[Marky_B]

I get this error?? when I run the macro

 

[juddaaaa]

Sorry. It can be difficult when you can't test things.

Try this

Sub CopyToMaster(Bk As String, Surname As String, Forename As String)

    Dim sn As Range, fn As Range
    Dim sht As Worksheet
    Dim nr As Long
  
    Application.ScreenUpdating = False

    If Dir(ThisWorkbook.Path & "\" & Bk) = "" Then
        MsgBox "Sorry, " & Bk & " does not exist.", vbInformation, "No such file"
        Exit Sub
    End If
  
    With Workbooks.Open(ThisWorkbook.Path & "\" & Bk, True, True)
        For Each sht In .Sheets
            Set sn = sht.Range("A8:A95").Find(What:=Surname, LookIn:=xlValues, LookAt:=xlWhole)
            Set fn = sht.Range("B8:B95").Find(What:=Forename, LookIn:=xlValues, LookAt:=xlWhole)
          
            If (Not sn Is Nothing And Not fn Is Nothing) Then
                If sn.Row = fn.Row Then
                    With ThisWorkbook
                        .Activate
                        
                        With .Sheets("Invoice")
                            .Activate
                            .Range("B13").Select
                            
                            With ActiveCell
                                .Value = sht.Range("A1") '// Cell A1 from Register_1
                                .Offset(, 1).Value = sht.Range("O" & sn.Row).Value '// Cell O from the row where then name was found
                                .Offset(1).Select '// Move down 1 in Invoice sheet....B14,B15,B16,B17
                            End With
                        End With
                    End With
                End If
            End If
        Next sht
      
        .Close _
            SaveChanges:=False
    End With

    Application.ScreenUpdating = True
  
End Sub

 

[Marky_B]

Am I aloud, can I share the files? Somehow To make it easier to code and test.
I have removed all personnel data, and replaced with test data. (so no GDPR issues)

 

[juddaaaa]

Yes. You would have to share it via Google Drive, Dropbox etc. and post the link

 

[Marky_B]

I've uploaded the files here. Think I've done it correctly

"Project.rar"

Thanks again

 

[juddaaaa]

OK. I think I might have it

Sub CopyToMaster(Bk As String, Surname As String, Forename As String)

    Dim sn As Range, fn As Range
    Dim sht As Worksheet
    Dim nr As Long
 
    Application.ScreenUpdating = False
   
    nr = 13

    If Dir(ThisWorkbook.Path & "\" & Bk) = "" Then
        MsgBox "Sorry, " & Bk & " does not exist.", vbInformation, "No such file"
        Exit Sub
    End If
 
    With Workbooks.Open(ThisWorkbook.Path & "\" & Bk, True, True)
        For Each sht In .Sheets
            Set sn = sht.Range("A8:A95").Find(What:=Surname, LookIn:=xlValues, LookAt:=xlWhole)
            Set fn = sht.Range("B8:B95").Find(What:=Forename, LookIn:=xlValues, LookAt:=xlWhole)
         
            If (Not sn Is Nothing And Not fn Is Nothing) Then
                If sn.Row = fn.Row Then
                    With ThisWorkbook
                        .Activate
                       
                        With .Sheets("Invoice")
                            .Activate
                            .Range("B" & nr).Select
                                                       
                            With ActiveCell
                                .Value = sht.Range("A2") '// Cell A1 from Register_1
                                .Offset(, 1).Value = sht.Range("O" & sn.Row).Value '// Cell O from the row where then name was found
                                .Offset(1).Select '// Move down 1 in Invoice sheet....B14,B15,B16,B17
                               
                                nr = nr + 1
                            End With
                        End With
                    End With
                End If
            End If
        Next sht
     
        .Close _
            SaveChanges:=False
    End With

    Application.ScreenUpdating = True
 
End Sub

Is this somewhere near?

Week 5 has no John Smith, so doesn't appear.

 

[Marky_B]

This is fantastic!! thank you. Could you please get it to look through "Register_2" once finished with "Register_1" using the same search criteria, adding it on "invoice" sheet under "Register_1" data

 

[FatBoyClam]

Sorry - another observation @juddaaaa - the Find function will pick up the first instance of the searched text.

So, if you're looking for John Smith, who appears on row 10, you'll not get him if there's a John Doe on row 5 and Paul Smith on Row 7.

 

[juddaaaa]

Ok. Couple of alterations.

You now just pass in the full name as a single string i.e. John Smith

Sub OtherMacro()

    CopyToMaster _
        FullName:="John Smith"

End Sub

The code will then open every workbook who's name begins with Register_

For Each fl In fldr.Files
        If InStr(fso.GetBaseName(fl), "Register_") Then
            With Workbooks.Open(fl.Path, True, True)

and search each worksheet for the name John Smith

For Each sht In .Sheets
       For Each cc In sht.Range("B8:B95")
              If Join(Array(cc.Value, cc.Offset(, -1).Value), " ") = FullName Then

The rest is pretty much the same as before.

Sub OtherMacro()

    CopyToMaster _
        FullName:="John Smith"

End Sub

Sub CopyToMaster(FullName As String)

    Dim fso As Object, fldr As Object, fl As Object
    Dim cc As Range
    Dim sht As Worksheet
    Dim nr As Long
 
    Application.ScreenUpdating = False
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder(ThisWorkbook.Path)
    nr = 13

    For Each fl In fldr.Files
        If InStr(fso.GetBaseName(fl), "Register_") Then
            With Workbooks.Open(fl.Path, True, True)
                For Each sht In .Sheets
                    For Each cc In sht.Range("B8:B95")
                        If Join(Array(cc.Value, cc.Offset(, -1).Value), " ") = FullName Then
                            With ThisWorkbook
                                .Activate
                               
                                With .Sheets("Invoice")
                                    .Activate
                                    .Range("B" & nr).Select
                                                               
                                    With ActiveCell
                                        .Value = sht.Range("A2") '// Cell A1 from Register_1
                                        .Offset(, 1).Value = sht.Range("O" & cc.Row).Value '// Cell O from the row where then name was found
                                        .Offset(1).Select '// Move down 1 in Invoice sheet....B14,B15,B16,B17
                                    End With
                                End With
                            End With
                           
                            nr = nr + 1
                            Exit For
                        End If
                    Next cc
                Next sht
             
                .Close _
                    SaveChanges:=False
            End With
        End If
    Next fl

    Application.ScreenUpdating = True
 
End Sub

I added a John Smith to Week1 in Register_2