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]

I have had a chance to test the code and it works perfectly. Thank you so much.

The next issue I now have is on the "invoice" sheet I need the "cost per session" column to check column "Description" for contained text then check this table on the "home" sheet in workbook "Master" for example if the description contains "Register 1" then use that cost but if the "Description" column contains "Register 2" the use that cost

hope that makes sence

thank you

 

[juddaaaa]

Here you go

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 InRegister As String
    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")
                                        .Offset(, 1).Value = sht.Range("O" & cc.Row).Value
                                        
                                        InRegister = Replace(Left(.Value, 10), " ", "_")
                                        .Offset(, 2).Value = Sheets("Home").Range("M3:M7").Find(What:=InRegister, LookIn:=xlValues).Offset(, 1)
                                        
                                        .Offset(1).Select
                                    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

 

[Marky_B]

the extra lines of code now produce an error. Were so close!!

 

[juddaaaa]

It's probably this line

.Offset(, 2) = Sheets("Home").Range("M3:M7").Find(What:=InRegister, LookIn:=xlValues).Offset(, 1)

I've spelled Home with a capital "H" but in Post #21 you've spelled it with a lower-case "h"

Sub CopyToMaster(FullName As String)

    Dim fso As Object, fldr As Object, fl As Object
    Dim cc As Range
    Dim sht As Worksheet
    Dim InRegister As String
    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")
                                        .Offset(, 1) = sht.Range("O" & cc.Row)
                                        
                                        InRegister = Replace(Left(.Value, 10), " ", "_")
                                        .Offset(, 2) = Sheets("home").Range("M3:M7").Find(What:=InRegister, LookIn:=xlValues).Offset(, 1)
                                        
                                        .Offset(1).Select
                                    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

 

[Marky_B]

It is with a capital "H" however even with it changed to "h" I get the same error. It pull the first line of data correctly then errors out.
Thank you

 

[juddaaaa]

The problem is I've been writing the code on the basis that it's called Register_1, Register_2 etc.

It now says After School Club.

 

[Marky_B]

Sorry for the confusion. I have added code to the column D "Cost per Session" which works a treat however I don't know how to get ride of the N/A if column B "Description" is blank. With any luck the code I've wrote will help you to put it in the VBA code you wrote.

Thank you very much.

 

[juddaaaa]

OK then.

I've renamed M3 and M4 in the Home sheet to Breakfast Club and After School Club and changed the code to suit the new requirements.

This will now search for whatever comes before the word Week in the Description column on the Home sheet (M3 and M4) and copy the relevant price to the cost per session column

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 InRegister As String
    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")
                                        .Offset(, 1) = sht.Range("O" & cc.Row)
                                        
                                        InRegister = Left(.Value, Len(.Value) - (Len(.Value) - InStrRev(.Value, " Week") + 1))
                                       .Offset(, 2) = Sheets("Home").Range("M3:M4").Find(What:=InRegister, LookIn:=xlValues).Offset(, 1)
                                        
                                        .Offset(1).Select
                                    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

 

[Marky_B]

code works like a charm, thank you. Now to the next stage if possible. Currently we specify "John Smith" to search which is great for ad-hoc. Is there a way to get excel to search a sheet called "Pupils" in the "Master" workbook say find "John Smith" then move on to the next name in the list until all names have been done. I have added the below code to the end of your code so it saves the invoice with a new name, clears the sheet then renews the number.

Thank you again

 

[Marky_B]

Do I presume the above question is not possible?
thank you