I have my code which loads 2 workbooks, and copies them into a master workbook. However I am getting an
overflow error
when i'm trying to trim all cells in the pasted sheets (too remove the spaces).
Does anyone know why this overflow error would occur when trimming excess blank spaces in a whole sheet? Specifically I am getting the error on this part Target = Target.Value .
Sub Load()
LoadDailyWorkbook
LoadLastWeeksWorkbook
End Sub
Sub LoadDailyWorkbook()
Const A1BJ200 As String = "A1:BJ200"
Const A1L3 As String = "A1:L3"
Dim masterWB As Workbook
Dim dailyWB As Workbook
'Set Current Workbook as Master
Set masterWB = Application.ThisWorkbook
'Set some Workbook as the one you are copying from
Set dailyWB = getWorkbook(Sheets("Control Manager").Range("O2"))
If Not dailyWB Is Nothing Then
With dailyWB
'Copy the Range from dailyWB and Paste it into the MasterWB
.Worksheets("Summary1").Range(A1BJ200).Copy masterWB.Worksheets("Summary").Range("A1")
TrimRange masterWB.Worksheets("Summary").Range(A1BJ200)
'repeat for next Sheet
.Worksheets("risk1").Range(A1BJ200).Copy masterWB.Worksheets("risk").Range("A1")
TrimRange masterWB.Worksheets("risk").Range(A1BJ200)
'repeat for CS sheet
.Worksheets("CS today").Range(A1L3).Copy masterWB.Worksheets("CS").Range("A1").Rows("1:1")
TrimRange masterWB.Worksheets("CS").Range(A1L3)
.Close SaveChanges:=False
End With
End If
End Sub
Sub LoadLastWeeksWorkbook()
Const A1BJ200 As String = "A1:BJ200"
Dim masterWB As Workbook
Dim lastweekWB As Workbook
'Set Current Workbook as Master
Set masterWB = Application.ThisWorkbook
''''''''''''Get Last Week Data''''''''''''''''''''''
Set lastweekWB = getWorkbook(Workbooks.Open(Sheets("Control Manager").Range("O3")))
If Not lastweekWB Is Nothing Then
With lastweekWB
'repeat for next risk Sheet
.Worksheets("risk2").Range(A1BJ200).Copy masterWB.Worksheets("risk_lastweek").Range("A1")
TrimRange masterWB.Worksheets("risk_lastweek").Range(A1BJ200)
TrimRange masterWB.Columns("A:BB")
.Close SaveChanges:=False
End With
End If
End Sub
Function getWorkbook(FullName As String) As Workbook
If Len(Dir(FullName)) = 0 Then
MsgBox FullName & " not found found", vbCritical, "File Not Found"
Else
Set getWorkbook = Workbooks.Open(FullName)
End If
End Function
Sub TrimRange(Target As Range)
Dim results As Variant
Set Target = Intersect(Target.Parent.UsedRange, Target)
If Target Is Nothing Then
Exit Sub
ElseIf Target.Count = 1 Then
Target.Value = Trim(Target.Value)
Exit Sub
Else
Target = Target.Value
Dim r As Long, c As Long
For r = 1 To UBound(results)
For c = 1 To UBound(results, 2)
results(r, c) = Trim(results(r, c))
Next
Next
Target.Value = results
End If
Target.Columns.EntireColumn.AutoFit
End Sub
Sub TrimRange(Target As Range)
Dim results As Variant
And yet, you do not set results before you use it.
For r = 1 To UBound(results)
So you are calling UBound on some thing that does not exist.
In addition, when I have changed formulas to values, I have used Target.Value = Target.Value instead of Target = Target.Value. I know the .Value is usually the default value, but I never trust implicit stuff to work all the time.
Related
I found this code below to help combine multiple sheets of data into one, however, it won't take from multiple sheets. I have two sheets and it either grabs one or the other. I tried to add on to it to specify more than one sheet but that doesn't seem to work either. How can I make this pull from multiple sheets? I have a sheet "anaheim" and sheet "Woodridge."
Sub Step3()
Dim i As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For i = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If i > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(i).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
Sub Step3()
Dim sh As Worksheet
Dim xRg As Range
Sheets.Add.Name = "MasterSheet"
For Each sh In Sheets
If sh.Name <> "MasterSheet" Then
sh.UsedRange.Copy Sheets("MasterSheet").Cells(Sheets("MasterSheet").Rows.Count, "A").End(xlUp).Offset(1)
End If
Next
End Sub
Backup Used Ranges
Option Explicit
Sub backupUsedRanges()
' Target Worksheet
Const tgtSheetName As String = "MasterSheet"
Const tgtFirstCell As String = "A1"
' Workbook
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Check if a sheet named 'tgtSheetName' already exists.
Dim Msg As Variant
If SheetExists(wb, tgtSheetName) Then
Msg = MsgBox("A sheet named '" & tgtSheetName _
& "' already exists. Do you want to delete it?", _
vbYesNo + vbExclamation, "Delete?")
If Msg = vbYes Then
Application.DisplayAlerts = False
wb.Worksheets(tgtSheetName).Delete
Application.DisplayAlerts = True
Else
MsgBox "Backup NOT created.", vbExclamation, "Fail"
Exit Sub
End If
End If
' Define (add) Target Worksheet ('tgt').
Dim tgt As Worksheet
Set tgt = wb.Worksheets.Add(Before:=wb.Sheets(1))
tgt.Name = tgtSheetName
' Define Next Target First Available Cell Range ('cel').
Dim cel As Range
Set cel = tgt.Range(tgtFirstCell)
' Write from Source Worksheets ('src') to Target Worksheet.
Dim src As Worksheet ' Current Source Worksheet
Dim rng As Range ' Current Source Used Range
For Each src In wb.Worksheets
If StrComp(src.Name, tgtSheetName, vbTextCompare) <> 0 Then
' Define Current Source Used Range ('rng').
Set rng = src.UsedRange
' Copy Current Source Used Range to Target Worksheet.
rng.Copy cel
' Define Next Target First Available Cell Range.
Set cel = cel.Offset(rng.Rows.Count)
End If
Next src
' Inform user
MsgBox "Backup created.", vbInformation, "Success"
End Sub
Function SheetExists(Book As Workbook, SheetName As String) As Boolean
Dim sh As Object
For Each sh In Book.Sheets
If StrComp(sh.Name, SheetName, vbTextCompare) = 0 Then
SheetExists = True
Exit Function
End If
Next sh
End Function
i have created a vba script which helps me to create new sheets in my workbook every time i enter a new column. What i want to change is to create a new sheet but copying a template sheet for that new sheet.
I basically create a "home sheet" where i will divide the curriculum into lessons, then i want the script to run and create a lesson plan sheet for each lesson. Please can someone help me with this?
Sub add()
Call CreateWorksheets(Sheets("Lesson List").Range("B2:XFD2"))
End Sub
Sub CreateWorksheets(Names_Of_Sheets As Range)
Dim No_Of_Sheets_to_be_Added As Integer
Dim Sheet_Name As String
Dim i As Integer
No_Of_Sheets_to_be_Added = Names_Of_Sheets.Columns.Count
For i = 1 To No_Of_Sheets_to_be_Added
Sheet_Name = Names_Of_Sheets.Cells(1, i).Value
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets.add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)).Name = Sheet_Name
End If
Next i
End Sub
Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet
Sheet_Exists = False
For Each Work_sheet In ThisWorkbook.Worksheets
If Work_sheet.Name = WorkSheet_Name Then
Sheet_Exists = True
End If
Next
End Function
My edited code with me trying to use the copy function:
Sub add()
Call CreateWorksheets(Sheets("Lesson List").Range("B2:XFD2"))
End Sub
Sub CreateWorksheets(Names_Of_Sheets As Range)
Dim No_Of_Sheets_to_be_Added As Integer
Dim Sheet_Name As String
Dim i As Integer
'determine the number of sheets to create
No_Of_Sheets_to_be_Added = Names_Of_Sheets.Columns.Count
For i = 1 To No_Of_Sheets_to_be_Added
'lable each sheet
Sheet_Name = Names_Of_Sheets.Cells(1, i).Value
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets("Lesson Plan Template").Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = Sheet_Name
End If
Next i
End Sub
Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet
Sheet_Exists = False
For Each Work_sheet In ThisWorkbook.Worksheets
If Work_sheet.Name = WorkSheet_Name Then
Sheet_Exists = True
End If
Next
End Function
Although i have not tidy up the error handling and my function as suggested i did follow the suggest of adding additional steps which gave me the desirable results:
Sub Add_New_Lesson()
Call Copy_Lesson_Template(Sheets("Lesson List").Range("B2:XFD2"))
End Sub
Sub Copy_Lesson_Template(Names_Of_Sheets As Range)
Dim No_Of_Sheets_to_be_Added As Integer
Dim Sheet_Name As String
Dim i As Integer
No_Of_Sheets_to_be_Added = Names_Of_Sheets.Columns.Count
For i = 1 To No_Of_Sheets_to_be_Added
Sheet_Name = Names_Of_Sheets.Cells(1, i).Value
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets("Lesson Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = (Sheet_Name)
End If
Next i
End Sub
Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet
Sheet_Exists = False
For Each Work_sheet In ThisWorkbook.Worksheets
If Work_sheet.Name = WorkSheet_Name Then
Sheet_Exists = True
End If
Next
End Function
Check out the following solution including some proper error handling.
Sub CreateWorksheets(Names_Of_Sheets As Range)
'determine the number of sheets to create
Dim No_Of_Sheets_to_be_Added As Long
With Names_Of_Sheets
No_Of_Sheets_to_be_Added = .Resize(ColumnSize:=1).Offset(ColumnOffset:=.Columns.Count - .Column + 1).End(xlToLeft).Column - .Column + 1
End With
Dim i As Long
For i = 1 To No_Of_Sheets_to_be_Added
Dim Sheet_Name As String
Sheet_Name = Names_Of_Sheets.Cells(1, i).Value
If Not Sheet_Exists(Sheet_Name) And Sheet_Name <> vbNullString Then
Dim TemplateCopy As Worksheet
Set TemplateCopy = Nothing 'initialize (needed because we are within a loop)
On Error Goto COPY_TEMPLATE_ERROR 'if error occurs throw message
Set TemplateCopy = Worksheets("Lesson Plan Template").Copy(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
On Error Goto 0 're-enable error handling!
If Not TemplateCopy Is Nothing Then 'check if the template copy exists
On Error Goto RENAME_COPY_ERROR
TemplateCopy.Name = Sheet_Name
On Error Goto 0 're-enable error handling!
End If
End If
Next i
Exit Sub
COPY_TEMPLATE_ERROR:
MsgBox "Template worksheet could not be copied."
Resume
RENAME_COPY_ERROR:
MsgBox "Template could not be renamed to '" & Sheet_Name & "'!"
'remove the template copy that could not be renamed (or you will have orphaned template copys)
Application.DisplayAlerts = False
TemplateCopy.Delete
Application.DisplayAlerts = True
Resume
End Sub
Make sure ActiveWorkbook is what you actually mean it to be:
ActiveWorkbook is the workbook that has focus (is on top of the other windows) while the code runs. This can easily change by a single mouse click.
ThisWorkbook is the workbook this VBA code is written in. It will never change. Use this over ActiveWorkbook when ever possible. This is much more reliable.
Note that if you work with multiple workbooks, every Worksheets or Sheets object needs to start with either ActiveWorkbook.Worksheets, ThisWorkbook.Worksheets or Workbooks("your-workbook-name.xlsm").Worksheets otherwise it is not clear for VBA which one of these you actually mean and it makes a guess (and it might guess wrong).
Finally the name of your function Sheet_Exists is a bit missleading because it only works for Worksheets as it is coded right now. Make sure you know the difference:
Sheets() contains all type of sheets: Worksheet, chart sheet, etc.
Worksheets() only contains sheets of type worksheet.
So your function should be called Worksheet_Exists
Function Worksheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet
For Each Work_sheet In ThisWorkbook.Worksheets
If Work_sheet.Name = WorkSheet_Name Then
Worksheet_Exists = True
Exit Function 'if we found the name we don't need to check further worksheets
End If
Next Work_sheet
End Function
Or it needs to be changed to work for all type of sheets:
Function Sheet_Exists(Sheet_Name As String) As Boolean
Dim Sheet As Object
For Each Sheet In ThisWorkbook.Sheets
If Sheet.Name = Sheet_Name Then
Sheet_Exists = True
Exit Function 'if we found the name we don't need to check further sheets
End If
Next Sheet
End Function
I am working with an EXCEL file with 11 worksheets, in this configuration:
VOL_CODE = The code that I look for. If present in a worksheet, the entire line containing VOL_CODE should be deleted.
Worksheets:
“NEW VOL DATA” –This is the worksheet that “stays on” (‘Active’ or ‘Selected’) during the whole process.
Also, here are in range K1:K10 the indications (“X”) if the destination worksheets are selected or not.
“DESTINATION1”, “DESTINATION2”, “DESTINATION3” ... “DESTINATION10”
“Target” worksheets where if VOL_CODE appears AND worksheet is indicated as ‘selected’ (in “NEW VOL DATA” worksheet), it’s line should be removed.
Code:
Private Sub CommandButton3_Click()
'--- Remove VOL_CODE line from all worksheets -----
Dim ws1, ws2 As Worksheet
Dim VOL_CODE As String
Dim PLA, LIN As Integer
Set ws1 = Worksheets("NEW VOL DATA") '--- This is the Working Worksheet -----
VOL_CODE = “RS_123456” ‘--- This is the code to search for -----
For PLA = 1 To 10
If UCase(Range("K" & PLA)) <> "X" Then GoTo JUMP_PLA:
Set ws2 = Worksheets("DESTINATION" & Trim(Str(PLA)))
Do While True
On Error GoTo JUMP_PLA:
LIN = Application.WorksheetFunction.Match(VOL_CODE, ws2.Range("B:B"), 0)
ws2.Cells(LIN, 1).EntireRow.Delete
Loop
JUMP_PLA:
Next PLA
End Sub
The problem is, when I execute the code, it goes fine in DESTINATION1 worksheet, containing or not VOL_CODE (if it does, it loops deleting VOL_CODE’s lines until there are no more), then, when finding no more entries for VOL_CODE, it goes to “JUMP_PLA:” and “Next PLA”... There it starts over, now going to next “DESTINATIONx” worksheet (the next selected)... And there’s an error (finding or not a valid entry) when the Application.WorksheetFunction.Match command executes :
Error in execution: 1004
Application definition or Object definition error
I know it must be a stupid error, but as I am a newbie, I cannot visualize it. And it is driving me crazy...
Can anyone give me a light? It would be very appreciated, and I thank you in advance.
Application.WorksheetFunction.Match to Delete Rows
The procedure doDest is best copied into a standard module (e.g. Module1) and then called in your button code:
Private Sub CommandButton3_Click()
doDest
End Sub
I left your code inside it, so you could see the mistakes and some options.
The rest of the code is just some toys a created to play with, since I've never seen Match used for deleting rows.
IF you wanna play, copy the complete code into a standard module in a new workbook and rename a worksheet to NEW VOL DATA. In range K1:K10 of it, enter an x in a few cells and you're good to go.
The Code
Option Explicit
Sub doDest()
'--- Remove VOL_CODE line from all worksheets -----
' Speed up the code (you won't see what the macro is doing).
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet 'Dim ws1, ws2 As Worksheet
Dim VOL_CODE As String
Dim PLA As Long, LIN As Long ' Dim PLA, LIN As Integer
Dim wb As Workbook: Set wb = ThisWorkbook ' The workbook with this code.
Set ws1 = wb.Worksheets("NEW VOL DATA") 'Set ws1 = Worksheets("NEW VOL DATA") '--- This is the Working Worksheet -----
VOL_CODE = "RS_123456" '--- This is the code to search for -----
For PLA = 1 To 10
'If StrComp(ws1.Range("K" & PLA).Value, "X", vbTextCompare) <> 0 _
Then GoTo JUMP_PLA
If UCase(ws1.Range("K" & PLA).Value) <> "X" Then GoTo JUMP_PLA ' If UCase(Range("K" & PLA)) <> "X" Then GoTo JUMP_PLA:
Set ws2 = wb.Worksheets("DESTINATION" & PLA) ' Set ws2 = Worksheets("DESTINATION" & Trim(Str(PLA)))
Do ' Do While True
' On Error GoTo JUMP_PLA:
' LIN = Application.WorksheetFunction.Match(VOL_CODE, ws2.Range("B:B"), 0)
' ws2.Cells(LIN, 1).EntireRow.Delete
On Error Resume Next ' Turn ON error trapping.
' "ws2.Columns("B")" is just an option, you can stick with
' "ws2.Range("B:B")".
LIN = Application.WorksheetFunction _
.Match(VOL_CODE, ws2.Columns("B"), 0)
If Err.Number <> 0 Then
On Error GoTo 0 ' Turn OFF error trapping.
'Debug.Print "Done with worksheet '" & ws2.Name & "'."
Exit Do ' or: GoTo JUMP_PLA
Else
On Error GoTo 0 ' Turn OFF error trapping.
ws2.Cells(LIN, 1).EntireRow.Delete
End If
Loop
JUMP_PLA:
Next PLA
Application.ScreenUpdating = True
MsgBox "Deleted rows containing '" & VOL_CODE & "'.", _
vbInformation, "Success"
End Sub
' Deletes all sheets named "DESTINATIONx", where x is from 1 to 10.
Sub deleteDest()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim i As Long
For i = 1 To 10
Application.DisplayAlerts = False ' To prevent Excel from 'complaining'.
On Error Resume Next ' If a sheet does not exist.
wb.Sheets("DESTINATION" & i).Delete
On Error GoTo 0
Application.DisplayAlerts = True
Next i
End Sub
' Adds worksheets named "DESTINATIONx", where x is from 1 to 10.
' In each of those worksheets, adds "RS_123456" to up to 100 cells
' in 'random' rows from 1 to 1000 in column 'B'.
Sub createDest()
' Speed up the code (you won't see what the macro is doing).
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet, i As Long, j As Long, CurrName As String
For i = 1 To 10
CurrName = "DESTINATION" & i
On Error Resume Next ' Turn ON error trapping.
Set ws = wb.Worksheets(CurrName)
If Err.Number <> 0 Then
' Sheet with current name does not exist.
Set ws = wb.Worksheets _
.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = CurrName
'Else ' Sheet with current name exists.
End If
On Error GoTo 0 ' Turn OFF error trapping.
ws.Columns("B").Clear ' Ensures new data if sheets already exist.
For j = 1 To 100
ws.Cells(Application.WorksheetFunction.RandBetween(1, 1000), "B") _
.Value = "RS_123456"
Next j
Next i
wb.Sheets(1).Select
Application.ScreenUpdating = True
End Sub
' Counts the number of cells in column 'B' containing a value.
Sub countDest()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim i As Long
For i = 1 To 10
On Error Resume Next
Debug.Print "DESTINATION" & i, wb.Worksheets("DESTINATION" & i) _
.Columns("B") _
.SpecialCells(xlCellTypeConstants) _
.Cells.Count
If Err.Number <> 0 Then
Debug.Print "DESTINATION" & i, "No cells found."
End If
Next i
End Sub
' Ultimate test
Sub testDest()
deleteDest ' Deletes the sheets.
createDest ' Creates the worksheets with random data.
countDest ' Counts the cells containing "RS_123456" (Debug.Print).
doDest ' Deletes the rows containing "RS_123456" in column 'B'.
countDest ' Counts the cells containing "RS_123456" (Debug.Print).
MsgBox "Ultimate: deleted, created, counted, done and counted again."
End Sub
' Initialize
Sub initCreateAndCount()
deleteDest ' Deletes the sheets.
createDest ' Creates the worksheets with random data.
countDest ' Counts the cells containing "RS_123456" (Debug.Print).
MsgBox "Initialized: Sheets deleted and created, and cells counted."
End Sub
' Shows how even when the 'dest' sheets exist, new values are generated.
Sub testCreateCount()
createDest ' Creates the worksheets with random data.
countDest ' Counts the cells containing "RS_123456" (Debug.Print).
MsgBox "Sheets created and cells counted."
End Sub
Here's a slightly re-worked version.
See comments for notes about changes
Private Sub CommandButton3_Click()
Dim ws1 As Worksheet, ws2 As Worksheet '<< need type for every variable,
' not just the last one...
Dim VOL_CODE As String
Dim PLA As Long, LIN As Long, m '<< use Long, not Integer
Set ws1 = Worksheets("NEW VOL DATA") 'Working Worksheet
VOL_CODE = "RS_123456" '<<< no smart quotes...
For PLA = 1 To 10
If UCase(ws1.Range("K" & PLA)) = "X" Then
Set ws2 = Worksheets("DESTINATION" & PLA)
m = Application.Match(VOL_CODE, ws2.Range("B:B"), 0)
Do While Not IsError(m) '<<< Test return value instead of
' trapping run-time error
ws2.Rows(m).Delete
m = Application.Match(VOL_CODE, ws2.Range("B:B"), 0)
Loop
End If
Next PLA
End Sub
I have a client who is hand holding a bunch of worksheets that should be standardized. They are created from importing CSV files. Basically, I need to replace the current manual sheets while they are being referenced from another tab without breaking the current references.
I've reduced the problem to a single workbook with 2 sheets. Sheet1 cell A1 references Sheet2 cell A1 which holds the string "Sheet2A1CellData"
Everything commented out below has been tried including Application.Volatile and Application.Calculation.
Option Explicit
Sub TestSheet2Delete()
Dim TmpSheet2 As Worksheet: Set TmpSheet2 = Sheets("Sheet2")
'Application.Volatile
If TmpSheet2 Is Nothing Then
Exit Sub
End If
'Application.Calculation = False
Application.DisplayAlerts = False
TmpSheet2.Delete
Application.DisplayAlerts = True
Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
If TmpSheet2 Is Nothing Then
Exit Sub
End If
TmpSheet2.Name = "Sheet2"
TmpSheet2.Range("A1").Value = "Sheet2A1CellData"
'Application.Calculation = True
End Sub
Sheet1 A1 was originally =Sheet2!A1. When I run the function above from the VBE, Sheet1 cell A1 is set to =#REF!A1.
How can I keep the reference valid after the sheet has been replaced?
Obviously, the real world problem is much larger and re-importing CSV data requires updating 132,000 cells. 6000 rows x 22 Columns.
Thanks for any help.
Thank you presenting a real good question.
First of all disclaimer: This is not an direct solution but and workaround we had to adopt years back.
Exactly similar problem problem had been encountered in my workplace (literally made us to pull out our hairs), and we also tried to go for iNDIRECT. But since the formulas in the working sheets are complex we failed to replace them with INDIRECT. So instead of lengthy manual replacement of the hundreds of Formulas in the working sheet, we used to insert a temp Sheet and change the formulas reference to that sheet. After importing new sheet and renaming it as old sheet's name, formulas were reverted back to original.
I tried to reproduce the code used (since I don't have access to same files now). We only used the Sub ChangeFormulas, Here I used the same in line with your code.
Option Explicit
Sub TestSheet2Delete()
Dim Wb As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet, Ws2 As Worksheet
Dim Xstr As String, Ystr As String
Set Wb = ThisWorkbook
Set Ws = Wb.Sheets("Sheet1")
Xstr = "Sheet2"
Ystr = "TempSheetX"
Set Ws1 = Wb.Sheets(Xstr)
Set Ws2 = Worksheets.Add(After:=Ws)
Ws2.Name = Ystr
DoEvents
ChangeFormulas Ws, Xstr, Ystr
Application.DisplayAlerts = False
Ws1.Delete
' Now again add another sheet with Old name and change formulas back to Original
Set Ws1 = Worksheets.Add(After:=Ws)
Ws1.Name = Xstr
DoEvents
ChangeFormulas Ws, Ystr, Xstr
Ws2.Delete
Application.DisplayAlerts = True
End Sub
Sub ChangeFormulas(Ws As Worksheet, Xstr As String, Ystr As String)
Dim Rng As Range, C As Range, FirstAddress As String
Set Rng = Ws.UsedRange
With Rng
Set C = .Find(What:=Xstr, LookIn:=xlFormulas)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
C.Formula = Replace(C.Formula, Xstr, Ystr)
Set C = .FindNext(C)
If C Is Nothing Then Exit Do
If C.Address = FirstAddress Then Exit Do
Loop
End If
End With
End Sub
Another simplest workaround is not to delete the Sheet at all and import the CSV and copy the full sheet onto the sheet in question. However This fully depends on actual working conditions involving CSV and all.
AFTER I posted (of course :-)), this link came up on the right: Preserve references that recommends using INDIRECT. I have now changed Sheet1 A1 to =INDIRECT("Sheet2!"&"A1").
I am not certain why the named ranges suggested in the link are needed. The indirect call above seems to work without a named range.
If this works in the larger project, I will mark this as complete.
My original answer did not work for non-contiguous cells. However, I really like the Range to Variants and then back to Range pattern. Very fast. So I rewrote my original answer into more reusable code that tests using non-contiguous cells.
Function PreserveFormulaeInVariantArr(ByVal aWorksheet As Worksheet, _
ByVal aIsNoFormulaErr As Boolean, _
ByRef aErrStr As String) As Variant
Dim TmpRange As Range
Dim TmpAreaCnt As Long
Dim TmpVarArr As Variant
Dim TmpAreaVarArr As Variant
PreserveFormulaeInVariantArr = Empty
If aWorksheet Is Nothing Then
aErrStr = "PreserveFormulaeInVariantArr: Worksheet is Nothing."
Exit Function
End If
Err.Clear
On Error Resume Next
Set TmpRange = aWorksheet.Cells.SpecialCells(xlCellTypeFormulas)
If Err.Number <> 0 Then 'No Formulae.
PreserveFormulaeInVariantArr = Empty
If aIsNoFormulaErr Then
aErrStr = "PreserveFormulaeInVariantArr: No cells with formulae."
End If
Exit Function
End If
TmpAreaVarArr = Empty
On Error GoTo ErrLabel
ReDim TmpVarArr(1 To TmpRange.Areas.Count, 1 To 2)
For TmpAreaCnt = LBound(TmpVarArr) To UBound(TmpVarArr)
TmpVarArr(TmpAreaCnt, 1) = TmpRange.Areas(TmpAreaCnt).Address 'Set 1st Element to Range
TmpAreaVarArr = TmpRange.Areas(TmpAreaCnt).Formula 'Left TmpArrVarArr for Debugging
TmpVarArr(TmpAreaCnt, 2) = TmpAreaVarArr 'Creates Jagged Array
Next TmpAreaCnt
PreserveFormulaeInVariantArr = TmpVarArr
Exit Function
ErrLabel:
aErrStr = "PreserveFormulaeInVariantArr - Error Number: " + CStr(Err.Number) + " Error Description: " + Err.Description
End Function
Function RestoreFormulaeFromVariantArr(ByVal aWorksheet As Worksheet, _
ByVal aIsEmptyAreaVarArrError As Boolean, _
ByVal aAreaVarArr As Variant, _
ByRef aErrStr As String) As Boolean
Dim TmpVarArrCnt As Long
Dim TmpRange As Range
Dim TmpDim1Var As Variant
Dim TmpDim2Var As Variant
Dim TmpDim2Cnt As Long
Dim TmpDim2UBound As Long
RestoreFormulaeFromVariantArr = False
On Error GoTo ErrLabel
If aWorksheet Is Nothing Then
Exit Function
End If
If IsEmpty(aAreaVarArr) Then
If aIsEmptyAreaVarArrError Then
aErrStr = "RestoreFormulaeFromVariantArr: Empty array passed."
Else
RestoreFormulaeFromVariantArr = True
End If
Exit Function
End If
For TmpVarArrCnt = 1 To UBound(aAreaVarArr)
TmpDim1Var = aAreaVarArr(TmpVarArrCnt, 1) 'This is always the range.
TmpDim2Var = aAreaVarArr(TmpVarArrCnt, 2) 'This can be a Variant or Variant Array
aWorksheet.Range(TmpDim1Var).Formula = TmpDim2Var
Next TmpVarArrCnt
RestoreFormulaeFromVariantArr = True
Exit Function
ErrLabel:
aErrStr = "PreserveFormulaeInVariantArr - Error Number: " + CStr(Err.Number) + " Error Description: " + Err.Description
End Function
Sub TestPreserveFormulaeInVariantArr()
Dim TmpPreserveFormulaeArr As Variant
Dim TmpErrStr As String
Dim TmpIsNoFormulaErr As Boolean: TmpIsNoFormulaErr = True 'Change If Desired
Dim TmpEmptySheet1 As Boolean: TmpEmptySheet1 = False 'Change If Desired
Dim TmpSheet1 As Worksheet: Set TmpSheet1 = Sheets("Sheet1")
Dim TmpSheet2 As Worksheet
Err.Clear
On Error Resume Next
Set TmpSheet2 = Sheets("Sheet2")
On Error GoTo 0
'Always Delete Sheet2
If (TmpSheet2 Is Nothing) = False Then
Application.DisplayAlerts = False
TmpSheet2.Delete
Application.DisplayAlerts = True
Set TmpSheet2 = Nothing
End If
If TmpSheet2 Is Nothing Then
Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
TmpSheet2.Name = "Sheet2"
TmpSheet2.Range("A1") = "Sheet2A1"
TmpSheet2.Range("B1") = "Sheet2A1"
TmpSheet2.Range("C4") = "Sheet2C4"
If TmpEmptySheet1 Then
TmpSheet1.Cells.ClearContents
Else
TmpSheet1.Range("A1").Formula = "=Sheet2!A1"
TmpSheet1.Range("B1").Formula = "=Sheet2!B1"
TmpSheet1.Range("C4").Formula = "=Sheet2!C4"
End If
End If
TmpPreserveFormulaeArr = PreserveFormulaeInVariantArr(TmpSheet1, TmpIsNoFormulaErr, TmpErrStr)
If TmpErrStr <> "" Then
MsgBox TmpErrStr
Exit Sub
End If
'Break Formulae and Cause #Ref Violation
Application.DisplayAlerts = False
TmpSheet2.Delete
Application.DisplayAlerts = True
'Add Sheet2 Back
Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
TmpSheet2.Name = "Sheet2"
TmpSheet2.Range("A1") = "Sheet2A1"
TmpSheet2.Range("B1") = "Sheet2A1"
TmpSheet2.Range("C4") = "Sheet2C4"
'Restore Formulas Back to Sheet1
If RestoreFormulaeFromVariantArr(TmpSheet1, TmpIsNoFormulaErr, TmpPreserveFormulaeArr, TmpErrStr) = False Then
MsgBox TmpErrStr
Exit Sub
End If
End Sub
The TestPreserveFormulaeInVariantArr can be run in the VBE with options to set empty values. Any comments appreciated.
I am trying to color the background of all cells in column B whose content has changed via VBA.
The background changes if I manually update the cells but not when it changes via VBA. I can not get why it is not changing with the VBA.
In the worksheet module for the sheet called OriginalData I have
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And Target <> "" Then
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
I am updating the Column 2 on OriginalData with
Sub FindReplace_Updated_UnMatched_NAMES_Original_Prepperd_2()
Dim FindValues As Variant
Dim ReplaceValues As Variant
Dim wsFR As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim lRow As Long
Dim i As Long
Sheets("Updated_UnMatched").Select
Set wsFR = ThisWorkbook.Worksheets("Updated_UnMatched")
Set wsTarget = ThisWorkbook.Worksheets("OriginalData")
lRow = wsFR.Range("C" & wsFR.Rows.Count).End(xlUp).Row
FindValues = wsFR.Range("C1:C" & lRow).Value
ReplaceValues = wsFR.Range("D1:D" & lRow).Value
With wsTarget
If IsArray(FindValues) Then
For i = 2 To UBound(FindValues)
.Columns("B:B").Replace FindValues(i, 1), ReplaceValues(i, 1), xlWhole, xlByColumns, False
Next i
Else
End If
End With
End Sub
You likely errored out on Target <> "" and got stuck with Application.EnableEvents = False environment state.
First, go to the VBE's Immediate Windows (Ctrl+G) and enter the command Application.EnableEvents = True. While in the VBE, make this modification to your code for multiple Target cell counts.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And c.Value <> "" Then '<~~ c <> "", not Target <> ""
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
That should be enough to get you going.
When there is some errors during event handler execution, it doesn't work properly for next times. You can find and fix the errors and it will work properly.
As a quick fix, you can do these steps:
Add On Error Resume Next at the beginning of Worksheet_Change to
prevent errors make your code stop working.
Save your workbook in a macro enabled format and reopen it enabling
active content.
Run macro and it will work properly.
I tested your code and it worked for me in Excel 2013.
It is strongly recommended to fix your errors instead of hiding them using On Error Resume Next.