Hi all, I have different workbooks of different people's profile, eg. John.xlsx, Isabella.xlsx, etc. I need to update these workbooks and save them. For eg. I update Age from 'ThisWorkbook.Sheets.("All_Routines")'. I have written a code called "FindMatch", which selects a workbook name from Column C in Sheets.("Profiles") and finds a match in Column A in Sheets.("All_Routines"). If the match is found then it runs a macro "Add_Age" from column B "Routines".
"Add_Age" subroutine should open the matched workbook. For eg. If John.xlsx is matched then it should open John.xlsx from the Workbook_path in Sheets.("Profiles"). After the workbook is opened, it should copy the Age and paste it in the John.xlsx workbook.
Similarly, I expect to open the Isabella.xlsx and other workbooks and do the same.
ThisWorkbook.Sheets.("Profiles")
ThisWorkbook.Sheets.("All_Routines")
Final result in Workbook "John.xlsx"
Module "FindMatch"
Module "Add_Age"
What I have tried
I tried to store a temporary value i.e the workbook name in a 'tempValue' As String and pass that value in 'Add_Age' subroutine. But, then the problem is either tempvalue is not passed in the Add_Age or if it is passed then I can't call the 'Add_Age' because the macro names becomes 'Add_Age(Byval tempValue As String)'. Any solution to achieve this? Thank you.
"Add_Age" subroutine should open the matched workbook. For eg. If John.xlsx is matched then it should open John.xlsx from the Workbook_path in Sheets.("Profiles"). After the workbook is opened, it should copy the Age and paste it in the John.xlsx workbook.
Similarly, I expect to open the Isabella.xlsx and other workbooks and do the same.
ThisWorkbook.Sheets.("Profiles")
| A | B | C | |
| 1 | Workbook_Paths | Workbook_Name | |
| 2 | C:\Workbooks\John.xlsx | John.xlsx | |
3 | D:\New_Workbooks\Isabella.xlsx | Isabella.xlsx |
ThisWorkbook.Sheets.("All_Routines")
| A | B | C | D | |
| 1 | Profile_Name | Routines | Age | Weight |
2 | John.xlsx | Add_Age | 24 | 60 |
| 3 | Isabella.xlsx | Add_Weight | 21 | 55 |
Final result in Workbook "John.xlsx"
| A | B | C | |
| 1 | Profile_Name | Age | Weight |
| 2 | John | 24 | 60 |
Module "FindMatch"
VBA Code:
Sub FindMatch()
Dim ws As Worksheet, Sh As Worksheet
Dim wsRws As Long, wsRng As Range, w As Range
Dim shRws As Long, shRng As Range, s As Range
Dim WBName As String
Set ws = Sheets("Profiles")
Set Sh = Sheets("All_Routines")
With ws
wsRws = .Cells(Rows.Count, "D").End(xlUp).Row
Set wsRng = .Range(.Cells(1, "D"), .Cells(wsRws, "D"))
End With
With Sh
shRws = .Cells(Rows.Count, "A").End(xlUp).Row
Set shRng = .Range(.Cells(1, "A"), .Cells(shRws, "A"))
End With
For Each w In wsRng
For Each s In shRng
If w = s Then Run s.Offset(0, 1).Value
Next s
Next w
End SubModule "Add_Age"
VBA Code:
Sub Add_Age()
Dim wb As Workbook
Dim wb2 As Workbook
Dim WS1 As Worksheet
Set wb = ActiveWorkbook
Set WS1 = wb.Worksheets("Profiles")
Dim c As Range, FoundCells As Range
Dim firstaddress As String
Dim Wrkbk As Workbook
Dim wkbQuelle As Workbook
Dim strDateTime As String
Dim autOrdner As String
Dim FileName As String
Dim FinalFileName As String
Dim tmpWB As Workbook
Set tmpWB = ThisWorkbook
Dim tmpSheet As Worksheet
Set tmpSheet = tmpWB.Sheets("StandardPaths")
Application.ScreenUpdating = False
With Sheets("Profiles").Range("D1:D50")
'find first cell that contains "rec"
Set c = .Find("John.xlsx", LookIn:=xlValues)
'if the search returns a cell
If Not c Is Nothing Then
'note the address of first cell found
firstaddress = c.Address
Do
'FoundCells is the variable that will refer to all of the
'cells that are returned in the search
If FoundCells Is Nothing Then
Set FoundCells = c
Else
Set FoundCells = Union(c, FoundCells)
End If
'find the next instance of "rec"
Set c = .Cells.FindNext(c)
Loop While Not c Is Nothing And firstaddress <> c.Address
'after entire sheet searched, select all found cells
Set wkbQuelle = Workbooks.Open(FoundCells.Offset(0, -2).Value)
wkbQuelle.Sheets(1).Name = ("Profile")
'Example Copy Age
ThisWorkbook.Range("C2").Copy
ActiveWorkbook.Range("B2").Paste
strDateTime = Format(Date, "dd/mm/yy") & " " & Format(Time, "hh-mm-ss")
FolderPath = tmpSheet.Cells(3, 3).Value
Filename = ("_" & ActiveWorkbook.Name)
FinalFileName = strDateTime & Filename
wkbQuelle.Sheets(1).Columns.AutoFit
Call FrontendStatus
wkbQuelle.SaveAs Filename:=FolderPath & FinalFileName , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.ScreenUpdating = True
wkbQuelle.Close SaveChanges:=False
End If
End With
End SubWhat I have tried
I tried to store a temporary value i.e the workbook name in a 'tempValue' As String and pass that value in 'Add_Age' subroutine. But, then the problem is either tempvalue is not passed in the Add_Age or if it is passed then I can't call the 'Add_Age' because the macro names becomes 'Add_Age(Byval tempValue As String)'. Any solution to achieve this? Thank you.
VBA Code:
Sub FindMatch()
Dim tmpValue As String
For Each w In wsRng
For Each s In shRng
If w = s Then Run s.Offset(0, 1).Value
tmpValue = s.Offset(0, 1).Value
Next s
Next w
Sub Add_Age(ByVal tempValue As String)
Dim wb As Workbook
Dim wb2 As Workbook
Dim WS1 As Worksheet
Set wb = ActiveWorkbook
Set WS1 = wb.Worksheets("Profiles")
Dim c As Range, FoundCells As Range
Dim firstaddress As String
Dim Wrkbk As Workbook
Dim wkbQuelle As Workbook
Dim strDateTime As String
Dim autOrdner As String
Dim FileName As String
Dim FinalFileName As String
Dim tmpWB As Workbook
Set tmpWB = ThisWorkbook
Dim tmpSheet As Worksheet
Set tmpSheet = tmpWB.Sheets("StandardPaths")
Application.ScreenUpdating = False
With Sheets("Profiles").Range("D1:D50")
'find first cell that contains "rec"
Set c = .Find(tempValue, LookIn:=xlValues)
