GimpyHand
New Member
- Joined
- Jul 12, 2023
- Messages
- 4
- Office Version
- 365
- Platform
- Windows
- Mobile
- Web
Hey, I have some basic VBA code that copies a range (B:Z) from one sheet to another on worksheet_change. This works well and copies the values to the correct location (next empty row), but it also copies the same data to row 999+. Sometimes it;s 999, sometimes it's 1000, sometimes it's 1001.
There is nothing in the code that specifies this range or to copy the values to 2 locations.
I have attached the code for both sheets (Source and Destination) in case the worksheet_change code on the destination sheet is causing the issue. I have spent all morning trying to figure this out.
Thanks in advance for any help.
Source Sheet VBA
Destination Sheet VBA
There is nothing in the code that specifies this range or to copy the values to 2 locations.
I have attached the code for both sheets (Source and Destination) in case the worksheet_change code on the destination sheet is causing the issue. I have spent all morning trying to figure this out.
Thanks in advance for any help.
Source Sheet VBA
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo errhandler
'Exit sub if the selection is out of bounds
If Target.Column <> 27 Or Target.Row < 5 Or Target.Value <> "Yes" Then
Exit Sub
End If
'Copy completed entries to Completed worksheet
'Declare variables
Dim datarow As Long
Dim currentRow As Long
Dim liveRow As Long
Dim lastRow As Long
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim liveSheet As Worksheet
'Set worksheet targets
Set sourceSheet = ThisWorkbook.Worksheets("CI Master")
Set destinationSheet = ThisWorkbook.Worksheets("Master")
Set liveSheet = ThisWorkbook.Worksheets("Live Tracker")
datarow = Target.Offset(0, 2).Value 'Grabbing the row the data is on by offsetting 2 columns to the right
currentRow = Target.Offset(0, 3).Value 'Grab current row by offsetting 3 columns to the right
'Copy values from source sheet to live sheet when toggling live to yes
copyBZData = sourceSheet.Range("B" & currentRow & ":Z" & currentRow).Value
lastRow = liveSheet.Cells(liveSheet.Rows.Count, "B").End(xlUp).Row 'Find the last row on Live Tracker sheet
liveSheet.Range("B" & lastRow).Resize(, 25).Value = copyBZData 'Paste columns B to Z to liveSheet
Set copyBZData = Nothing
copyWZData = sourceSheet.Range("W" & currentRow & ":Z" & currentRow).Value
destinationSheet.Range("W" & datarow & ":Z" & datarow).Value = copyWZData
Set copyWZData = Nothing
'Delete W:Z and shift contents up
sourceSheet.Range("W" & currentRow & ":Z" & currentRow).Delete Shift:=xlShiftUp
destinationSheet.Range("AA" & datarow).Value = "Yes" ' Set Live value to Yes on Master Sheet
Target.Value = "" 'Set the selection to blank
errhandler:
Exit Sub
End Sub
Destination Sheet VBA
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow As Long
Dim xCol As Long
Dim xDPRg As Range
Dim xRg As Range
Dim datarow As Long
Dim currentRow As Long
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
' Set column and row targets
xCellColumn = 28
xTimeColumn = 29
xRow = Target.Row
xCol = Target.Column
' Paste Date/Time if Column X is not blank
If Target.Text = "Yes" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now()
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now()
End If
Next
End If
End If
On Error GoTo errhandler
' Exit Sub if the selection is out of bounds
If Target.Column() <> xCellColumn Or Target.Row() < 5 Or Target.Value() <> "Yes" Then
Exit Sub
End If
' Set worksheet targets
Set sourceSheet = ThisWorkbook.Worksheets("Live Tracker")
Set destinationSheet = ThisWorkbook.Worksheets("Master")
datarow = Target.Offset(0, 3).Value ' Grabbing the row the data is on by offsetting one column to the left
currentRow = Target.Offset(0, 2).Value ' Grab the row for the current sheet
' Copy values from source sheet to destination before toggling completed to yes
With sourceSheet
destinationSheet.Range("W" & datarow & ":Z" & datarow).Value = .Range("W" & currentRow & ":Z" & currentRow).Value
destinationSheet.Range("AC" & datarow).Value = .Range("AC" & currentRow).Value
End With
destinationSheet.Range("AA" & datarow).Value = "No" ' Set the live value to No
destinationSheet.Range("AB" & datarow).Value = "Yes" ' Set the completed value to Yes
' Clear the contents of the source range
sourceSheet.Range("B" & currentRow & ":AC" & currentRow).Delete Shift:=xlShiftUp
Target.Value = "" ' Reset the selection to blank
' Clean up
Application.CutCopyMode = False
Exit Sub
errhandler:
Exit Sub
End Sub