VBA Code Help Bounty 1/5 Star Difficulty

[yukonhoe]

Haven't bothered to read rules, apologies in advance. Wrote this awhile ago, forgot VBA since and don't have time atm to reteach myself. This might be against TOS but first to fix this, I might (I do) have :crying::crying::crying::crying::crying: for you, :crying: = 1 united state dollar... if this is against TOS can you please remove these lines from this post instead of deleting it and making me repost? Forums are aids.


Should be easy fix, prob need to move order in some form.

'''deletes rows with zero values in column D''' this part of code below, last piece, this isnt working correctly. It is only deleting some of the zeros but not all. Maybe bc insert 200 line is before this? This step could be done before the line add code in an order of operations, but not before column H is pasted hard values into column D.


Let me know, thx in advance; will pm solver. Might need to develop relationship with someone , monetarily that is, we back baby.



Public Sub PD()


'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False

'''insert 50 blank rows to make space for new period data'''
'''grabs count of new accruals for period from cell N1'''
Dim var As Integer
var = 200
Range("H" & lastRow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown


'''clear middle aread from columns E to H'''
Range("E3:G" & lastRow).ClearContents

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
last = Cells(Rows.Count, "D3").End(xlDown).Row
For i = last To 30 Step 1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete
End If
Next i




End Sub

[yukonhoe]

Duplicate the bounty if someone can tell me if there is method to updating 100+ excel sheets that currently have this glitched code in it into a different one. I understand you could just save in one file and keep open, would prefer the former.

edit - I also understand that this ^ has likely been discussed before either here or the www, cant bother to search for it :doh:

[arnelgp]

maybe delete the last portion of your code to:


'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
last = Cells(Rows.Count, "D").End(xlUp).Row

Do While last > 29
If Cells(last, "D").Value & "" = "0" Then
Rows(last).Delete
End If
last = last - 1
Loop

[jdelano]

If the value in D isn't a string it might cause the if fail.

I would try to surround the cell value with a CStr() function so that it converts any number to a string during the comparison.



'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
last = Cells(Rows.Count, "D3").End(xlDown).Row
For i = last To 30 Step 1
If CStr(Cells(i, "D").Value) = "0" Then
Cells(i, "D").EntireRow.Delete
End If
Next i

[Logit]

Here is the reworked macro :


Public Sub PD()

'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False

'''insert 50 blank rows to make space for new period data'''
'''grabs count of new accruals for period from cell N1'''
Dim var As Integer
var = 200
Range("H" & lastRow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown


'''deletes rows with zero values in column D'''
'Dim Sht As Worksheet
'Dim last As Long
'Dim i As Long
'Set Sht = ActiveSheet
'last = Cells(Rows.Count, "D3").End(xlDown).Row
'For i = last To 30 Step 1
' If Cells(i, "D").Value = "0" Then
' Cells(i, "D").EntireRow.Delete
' End If
'Next i

Dim lr As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
lr = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D" & lr) '<-- Change to corresponding row
.Replace " ", "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With
Application.ScreenUpdating = True





End Sub

[yukonhoe]

Still running into same issue, doesnt delete every row with a zero from column D, only some of them.

[yukonhoe]

maybe delete the last portion of your code to:


'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
last = Cells(Rows.Count, "D").End(xlUp).Row

Do While last > 29
If Cells(last, "D").Value & "" = "0" Then
Rows(last).Delete
End If
last = last - 1
Loop



This is close, all the zero value cells in column D are now grouped together, but still manually need to delete.

[yukonhoe]

If the value in D isn't a string it might cause the if fail.

I would try to surround the cell value with a CStr() function so that it converts any number to a string during the comparison.



'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
last = Cells(Rows.Count, "D3").End(xlDown).Row
For i = last To 30 Step 1
If CStr(Cells(i, "D").Value) = "0" Then
Cells(i, "D").EntireRow.Delete
End If
Next i

No dice, zero's in column D are still being skipped

[yukonhoe]

For those I have replied to, please see the excel file that user logit has linked, that is an example of my file if you want to play with it.

[jdelano]

The calc for the last row was always returning 0 and the step was 1 and not -1 ... it looks to me like it is doing what you need now.

[yukonhoe]

The calc for the last row was always returning 0 and the step was 1 and not -1 ... it looks to me like it is doing what you need now.
Can you paste the macro, something is up with excel files getting posted here, pc thinks they are dangerous since coming from web

[jdelano]

Can you paste the macro, something is up with excel files getting posted here, pc thinks they are dangerous since coming from web



'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
'last = Cells(Rows.Count, "D3").End(xlDown).Row
last = Sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete
'Cells(1, "J").Value = Cells(1, "J").Value & " " & CStr(i)
End If
Next i

[yukonhoe]

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long
Dim i As Long
Set Sht = ActiveSheet
'last = Cells(Rows.Count, "D3").End(xlDown).Row
last = Sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete
'Cells(1, "J").Value = Cells(1, "J").Value & " " & CStr(i)
End If
Next i


Close, all the values with zero in column d post macro are now lumped together, need it to delete these sheet row's after identifying that they are zero's. Everything else looks good.

[jdelano]

even before row 30? The loop has a hard stop there.

[yukonhoe]

Close, all the values with zero in column d post macro are now lumped together, need it to delete these sheet row's after identifying that they are zero's. Everything else looks good.

So the data within the sheet will always be changing, but it will always be setup the same . I ran on a diff data sheet and cells with positive integer in column d post macro column h pre macro were stand alone within the group of zero value rows. wish I could paste screenshots in this forum... lmk if this made any sense, either way zero's arent getting delete and if zero's get deleted this should work perfectly.

[yukonhoe]

even before row 30? The loop has a hard stop there.

Rows 1 and 2 need to stay put and not be altered, if you can see in original code I use ctrl down to set variable length of rows that need to be pasted over. it is variable number of rows, always different, but there is gap in data and totals at bottom so that totals are never grabbed. Ctrl down in column H should always be the number of rows , delete zero's in column d from these rows after paste values, but before adding 200 blank lines above totals/sum line

[yukonhoe]

even before row 30? The loop has a hard stop there.

I see what you mean with hard stop at 30, can we remove this piece? it is deleting all the zero's but leaving them from row 3-29.

[jdelano]

Okay, I'll take a look in the morning with all that in mind.

[arnelgp]

i thought you would stop deleting when it reach row 29?
so you want to process it until it reaches the Header of column D.

see ArnelGP_Test worksheet and press the button.

[Logit]

The FORMAT of cells in Col D to "Accounting" gave me a good run. After editing the format things moved along rather well.


Public Sub PD()

'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

Application.ScreenUpdating = False

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False

'''insert 50 blank rows to make space for new period data'''
'''grabs count of new accruals for period from cell N1'''
Dim var As Integer
var = 200
Range("H" & lastRow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown


Range("D1:D200").NumberFormat = "Number"

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long

Set Sht = ActiveSheet

last = Sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete

End If
Next i

Dim LR As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
LR = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D200" & LR) '<-- Change to corresponding row
.Replace 0, "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With

Range("E3:E200" & LR).ClearContents '<-- Change to corresponding row


Dim wbMe As Excel.Workbook
Dim cl As Excel.Range

Set wbMe = ThisWorkbook

'if number is negative, change to positive
Set cl = activeworksheet.Range("D3:D200").Select
If cl.Value < 0 Then
cl.Value = -cl.Value
End If

'clear the totals at bottom of ranges
LR = Range("A3").End(xlDown).Row
Rows(LR + 1 & ":" & 10000).Delete

Application.ScreenUpdating = True

End Sub

[yukonhoe]

The FORMAT of cells in Col D to "Accounting" gave me a good run. After editing the format things moved along rather well.


Public Sub PD()

'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

Application.ScreenUpdating = False

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False

'''insert 50 blank rows to make space for new period data'''
'''grabs count of new accruals for period from cell N1'''
Dim var As Integer
var = 200
Range("H" & lastRow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown


Range("D1:D200").NumberFormat = "Number"

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long

Set Sht = ActiveSheet

last = Sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete

End If
Next i

Dim LR As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
LR = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D200" & LR) '<-- Change to corresponding row
.Replace 0, "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With

Range("E3:E200" & LR).ClearContents '<-- Change to corresponding row


Dim wbMe As Excel.Workbook
Dim cl As Excel.Range

Set wbMe = ThisWorkbook

'if number is negative, change to positive
Set cl = activeworksheet.Range("D3:D200").Select
If cl.Value < 0 Then
cl.Value = -cl.Value
End If

'clear the totals at bottom of ranges
LR = Range("A3").End(xlDown).Row
Rows(LR + 1 & ":" & 10000).Delete

Application.ScreenUpdating = True

End Sub




All the zero's are getting deleted correctly it looks like, however I am losing the total/sum's rows below the data, I need this to carry over every time to macro is run. Copy values from H ctrl down (this doesnt grab the totals as there is blank row between data and totals/sums) paste values in d, delete zeros from d (using variable range of h + ctrl down) , delete out e:G + variable range of h +ctrl down, add 200 blank rows in between the h + ctrl down and the totals/sums

[Logit]

To retain the totals at the bottom of the range, delete the following lines of code located at the very bottom of the macro :


'clear the totals at bottom of ranges
LR = Range("A3").End(xlDown).Row
Rows(LR + 1 & ":" & 10000).Delete

[yukonhoe]

To retain the totals at the bottom of the range, delete the following lines of code located at the very bottom of the macro :


'clear the totals at bottom of ranges
LR = Range("A3").End(xlDown).Row
Rows(LR + 1 & ":" & 10000).Delete

How can I get the "insert 200 blank lines into this, doesnt appear to be adding lines.

[Logit]

Public Sub PD()

'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

Application.ScreenUpdating = False

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False



Range("D1:D200").NumberFormat = "Number"

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long

Set Sht = ActiveSheet

last = Sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete

End If
Next i

Dim LR As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
LR = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D200" & LR) '<-- Change to corresponding row
.Replace 0, "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With

Range("E3:E200" & LR).ClearContents '<-- Change to corresponding row


Dim wbMe As Excel.Workbook
Dim cl As Excel.Range

Set wbMe = ThisWorkbook

'if number is negative, change to positive
Set cl = activeworksheet.Range("D3:D200").Select
If cl.Value < 0 Then
cl.Value = -cl.Value
End If


'''insert 200 blank rows to make space for new period data'''

Dim numRowsToAdd As Integer


' Find the last used cell in column A
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

' Get the number of blank rows to add
numRowsToAdd = 200

' Add blank rows below the last used cell
For i = 1 To numRowsToAdd
Rows(lastRow + i).Insert Shift:=xlDown
Next i


Application.ScreenUpdating = False



''clear the totals at bottom of ranges
'LR = Range("A3").End(xlDown).Row
'Rows(LR + 1 & ":" & 10000).Delete

Application.ScreenUpdating = True

End Sub

[yukonhoe]

Public Sub PD()

'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

Application.ScreenUpdating = False

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False



Range("D1:D200").NumberFormat = "Number"

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long

Set Sht = ActiveSheet

last = Sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete

End If
Next i

Dim LR As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
LR = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D200" & LR) '<-- Change to corresponding row
.Replace 0, "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With

Range("E3:E200" & LR).ClearContents '<-- Change to corresponding row


Dim wbMe As Excel.Workbook
Dim cl As Excel.Range

Set wbMe = ThisWorkbook

'if number is negative, change to positive
Set cl = activeworksheet.Range("D3:D200").Select
If cl.Value < 0 Then
cl.Value = -cl.Value
End If


'''insert 200 blank rows to make space for new period data'''

Dim numRowsToAdd As Integer


' Find the last used cell in column A
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

' Get the number of blank rows to add
numRowsToAdd = 200

' Add blank rows below the last used cell
For i = 1 To numRowsToAdd
Rows(lastRow + i).Insert Shift:=xlDown
Next i


Application.ScreenUpdating = False



''clear the totals at bottom of ranges
'LR = Range("A3").End(xlDown).Row
'Rows(LR + 1 & ":" & 10000).Delete

Application.ScreenUpdating = True

End Sub

This appears to work, will run thru few diff formats and confirm

[Logit]

See if this works :


Public Sub PD()

'''rename sheet'''
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

'''duplicate current tab'''
If newName <> "" Then
ActiveSheet.Copy Before:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = newName
End If

Application.ScreenUpdating = False

'''copy end of period balances from I9 to last cell with data in row H5'''
Dim lastRow As Long
lastRow = Range("H3").End(xlDown).Row
Set Rng = Range("H3:H" & lastRow)


Range("H3:H" & lastRow).Copy


'''paste copied end balances and paste values to cell D5'''
ActiveSheet.Range("D3").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Applcation.CutCopyMode = False



Range("D1:D200").NumberFormat = "Number"

'''deletes rows with zero values in column D'''
Dim Sht As Worksheet
Dim last As Long

Set Sht = ActiveSheet

last = Sht.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row

For i = last To 30 Step -1
If Cells(i, "D").Value = "0" Then
Cells(i, "D").EntireRow.Delete

End If
Next i

Dim LR As Long
Application.ScreenUpdating = False '\/Change number 1 below to correspond to affected column.
LR = Sheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row '<----- Change to actual sheet name
With Range("D2:D200" & LR) '<-- Change to corresponding row
.Replace 0, "", xlWhole '<-- Currently checking for number 0. Edit as required
.SpecialCells(4).EntireRow.Delete
End With

Range("E3:E200" & LR).ClearContents '<-- Change to corresponding row


Dim wbMe As Excel.Workbook
Dim cl As Excel.Range

Set wbMe = ThisWorkbook

'if number is negative, change to positive
Set cl = activeworksheet.Range("D3:D200").Select
If cl.Value < 0 Then
cl.Value = -cl.Value
End If


'''insert 50 blank rows to make space for new period data'''
'''grabs count of new accruals for period from cell N1'''
'Dim var As Integer
'var = 50
'Range("A" & lastrow).EntireRow.Offset(1).Resize(var).Insert Shift:=xlDown




Dim numRowsToAdd As Integer


' Find the last used cell in column A
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

' Get the number of blank rows to add
numRowsToAdd = 200

' Add blank rows below the last used cell
For i = 1 To numRowsToAdd
Rows(lastRow + i).Insert Shift:=xlDown
Next i

Dim newrow As Long

' Find the last used cell in column D
lastRow = Cells(Rows.Count, 4).End(xlUp).Row
newrow = lastRow - 1
Rows(newrow).Insert Shift:=xlDown

Range("A1").Select
Application.ScreenUpdating = False



''clear the totals at bottom of ranges
'LR = Range("A3").End(xlDown).Row
'Rows(LR + 1 & ":" & 10000).Delete

Application.ScreenUpdating = True

End Sub

[snb]

Sub M_snb()
With Sheet2.Columns(8)
.SpecialCells(-4123, 1).Areas(1).Value = .SpecialCells(-4123, 1).Areas(1).Value
.SpecialCells(2, 1).Replace 0, "", 1
.SpecialCells(4).EntireRow.Delete
With .SpecialCells(2, 1).Areas(1)
.Offset(, -4) = .Value
.Offset(, -3).Resize(, 3).ClearContents
.Formula = "=sum($D2:$G2)"
End With
End With
End Sub

[Jan Karel Pieterse]

You mention updating the code in many files. Have a look at:
https://jkp-ads.com/download.asp#CopyVBAProject