VBA change cell value to run another macro - vba

Question

I hope you can help.
I have a lengthy piece of code, CODE 2 what this does is it allows a user to open a dialog box, select a sheet, once a sheet is selected it formats the sheet, filters the 7th column then adds new sheets with copied information from 7th column, names the sheets, formats again, adds and deletes columns, subtracts dates and returns numbers, and I essentially end up with what you see in Pic 1 (more happens but that is the gist of it) I am happy with CODE 2
I also have CODE 1 now with this if a user selects a value in A2 that is not "Enter Your Country Here" then all the "Enter Your Country Here" in the workbook get replaced with the new value in A2.
CODE 1 also works fine
The problem is i cant seem to join CODE 1 into CODE 2. CODE 1 works perfectly by itself but I cant seem to call it or get it to fire where ever I place or call it in CODE 2
Can CODE 1 be worked into CODE 2 so that when a user selects a country it finds and replaces "Enter Your Country Here" with the selected value in A2
Like a said both codes work fine separately I just need to bring 1 into 2 some how
As always any and all help is greatly appreciated.
Pic 1
CODE 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("A2")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' Display a message when one of the designated cells has been
' changed.
' Place your code here.
Call Find_Replace
End If
End Sub
Public Sub Find_Replace()
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
fnd = "Enter Your Country Here"
rplc = Worksheets("SearchCasesResults").Range("A2").Value
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
End Sub
CODE 2
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
MsgBox "Pick your Disputes file" '<--| txt box for prompt to pick a file
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection
If my_FileName <> False Then
Workbooks.Open Filename:=my_FileName
Call Sort_Disputes '<--|Calls Sort Disputes and begins to format
End If
End Sub
Public Sub Sort_Disputes()
With ActiveWorkbook.Sheets(1)
Rows("1:5").Delete '<--|Deletes the first 5 rows
Range("A1").EntireColumn.Insert '<--|Inserts a new A column
Range("A1").Value = "Market" '<--|Market text enters cell A1
Cells(1, 2).Copy
Cells(1, 1).PasteSpecial (xlPasteFormats) '<--|Keeps the formatting of other columns and forces to new column A
Application.CutCopyMode = False
Columns.AutoFit '<--|Auto fits the columns
Range("C:C,J:J,M:AF").EntireColumn.Delete '<--|Deletes Columns
Rows("2:2500").RowHeight = 25 '<--|Adjusts Row Height
Call populateA '<--|Calls PopulateA and this takes a look a Column A and where blank enters text
End With
Call Filter '<--|Calls Filter which looks down the 7th Column and seperates out the sheets to new tabs based on the value in Column 7
Call Activate_Sheet '<--|Deletes a column then subtracts todays date from the date in C and represents as a number in D
Call Activate_Sheet_2 '<--|As long as C is not blank it will subtract the Date in C from the Date in D and return a numerical result
Call Add_Sheet
End Sub
Public Sub Filter()
Dim rCountry As Range, helpCol As Range
With ActiveWorkbook.Sheets(1) '<--| refer to data worksheet
With .UsedRange
Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
End With
With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A"
.Columns(7).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 7th column of the referenced range and store its unique values in "helper" column
Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
.AutoFilter 7, rCountry.Value2 '<--| filter data on country field (7th column) with current unique country name
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet
ActiveSheet.Name = rCountry.Value2 '<--... rename it
.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
End If
Next
End With
.AutoFilterMode = False '<--| remove autofilter and show all rows back
End With
helpCol.Offset(-1).End(xlDown).EntireColumn.Delete '<--| clear helper column (header included)
End Sub
Public Sub populateA()
Dim WS As Worksheet
Dim lRow As Long
Set WS = ActiveWorkbook.Sheets(1)
With WS
lRow = .Range("B" & .Rows.Count).End(xlUp).Row '<--| Looks for the last empty cell in Column B
.Range("A2:A" & lRow).Formula = "=If(B2<>"""",""Enter Your Country Here"","""")" '<--| If there is no blank cell in B and A has a blank cell then A gets populated with "Enter your Country Here"
.Range("A2:A" & lRow).Value = .Range("A2:A" & lRow).Value
.Range("A2:A" & lRow).Interior.ColorIndex = 39 '<--|Changes the colour of A
End With
End Sub
Public Sub Activate_Sheet()
Worksheets("In Progress").Activate '<--|Activates Inprogress Sheet
Columns.AutoFit '<--|Auto fits Columns
Range("N:N").EntireColumn.Delete '<--|Delete Columns
Range("D1").Value = "# days open" '<--|Enters Value
Rows("2:2500").RowHeight = 25 '<--|Adjusts Row Height
Dim LastRow As Long, i As Long
With Worksheets("In Progress")
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row '<--|Looks for the last non empty cell in C
For i = 2 To LastRow
.Range("D" & i).Value = DateDiff("d", .Range("C" & i).Value, Date) '<--|As long as C is not blank it will subtract todays date from C and populate in D
Next i
End With
End Sub
Public Sub Activate_Sheet_2()
Worksheets("Complete").Activate '<--|Activates Complete Sheet
Columns.AutoFit '<--|Auto fits Columns
Range("N:N").EntireColumn.Delete '<--|Deletes Columns
Range("E1").EntireColumn.Insert '<--|Inserts Columns
Range("E1").Value = "Overall Ticket Aging" '<--|Enters Value
Rows("2:2500").RowHeight = 25 '<--|Adjusts Row Height
Dim LastRow As Long, i As Long
With Worksheets("Complete")
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 2 To LastRow
.Range("E" & i).Value = DateDiff("d", .Range("C" & i).Value, .Range("D" & i).Value) '<--|As long as C is not blank it will subtract the Date in C from the Date in D and return a numerical result
Next i
End With
Columns(5).NumberFormat = "0" '<--|Formats the 5 column to number format
End Sub
Public Sub Add_Sheet()
''Dim WS As Worksheet
''Set WS = Sheets.Add
Sheets.Add.Name = "Countries"
Worksheets("Countries").Activate
Range("A1").Value = "Country"
Range("A2").Value = "UK"
Range("A3").Value = "Belgium"
Range("A4").Value = "Bulgaria"
Range("A5").Value = "Croatia"
Range("A6").Value = "Czech Republic"
Range("A7").Value = "Slovenia"
Range("A8").Value = "Spain"
Range("A9").Value = "Italy"
Range("A10").Value = "Germany"
Worksheets("SearchCasesResults").Activate
Call Auto_Filter
End Sub
Public Sub Auto_Filter()
'replace "J2" with the cell you want to insert the drop down list
With Range("A2").Validation
.Delete
'replace "=A2:A6" with the range the data is in.
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Countries!A2:A10"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
To solve this I needed VBA code that would put Change Event VBA code into another worksheet. Calling the code I had was not working as I was calling a Change Event which didn't make sense. I needed code to put the change event into the sheet.
The code I used to put the change event into the the sheet in my example in the pic the sheet named "SearchCasesResults" is below I hope it helps someone.
CODE to put code into another sheet
Public Sub CreateEventProcedure()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Sheet1")
Set CodeMod = VBComp.CodeModule
With CodeMod
LineNum = .CreateEventProc("Change", "Worksheet")
LineNum = LineNum + 1
''.InsertLines LineNum, " MsgBox " & DQUOTE & "Hello World" & DQUOTE
''.InsertLines LineNum, " Cells.Columns.AutoFit"
''.InsertLines LineNum, " End Sub"
.InsertLines LineNum, " Worksheets(" & DQUOTE & "SearchCasesResults" & DQUOTE & ").Activate"
.InsertLines LineNum, " Next sht"
.InsertLines LineNum, " SearchFormat:=False, ReplaceFormat:=False"
.InsertLines LineNum, " LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _"
.InsertLines LineNum, " sht.Cells.Replace what:=fnd, Replacement:=rplc, _"
.InsertLines LineNum, " For Each sht In ActiveWorkbook.Worksheets"
.InsertLines LineNum, " rplc = Worksheets(" & DQUOTE & "SearchCasesResults" & DQUOTE & ").Range(" & DQUOTE & "A2" & DQUOTE & ").Value"
.InsertLines LineNum, " fnd = " & DQUOTE & "Enter Your Country Here" & DQUOTE & ""
.InsertLines LineNum, " Dim rplc As Variant"
.InsertLines LineNum, " Dim fnd As Variant"
.InsertLines LineNum, " Dim sht As Worksheet"
End With
End Sub