I have created a code to move a row when a field is marked as 'Complete' to another sheet on a separate tab, however it will not move the row to the next available row on the other sheet, it moves it to the next available row outside of the table. Can you please assist? This is the code I have:
Sub MoveRowsToCompletedJobs()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim i As Long
' Set the source and target sheets
Set sourceSheet = ThisWorkbook.Worksheets("WIP REPORT (ACTIVE)")
Set targetSheet = ThisWorkbook.Worksheets("COMPLETED_JOBS")
' Find the last row in the source sheet
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "P").End(xlUp).Row
' Loop through each row in the source sheet
For i = 2 To lastRow
' Check if cell in column P contains "COMPLETED"
If sourceSheet.Cells(i, "P").Value = "COMPLETED" Then
' Copy the entire row to the target sheet
sourceSheet.Rows(i).Copy Destination:=targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Offset(1)
' Delete the row from the source sheet
sourceSheet.Rows(i).Delete
' Decrement the loop counter as the rows are shifting up
i = i - 1
' Update the last row value
lastRow = lastRow - 1
End If
Next i
End Sub
Tried the code above and whilst it moved the row to the second tab, it moves to the next available row outside of the table. Is it because one table has more columns than the other?
WIP Report active tab (source sheet)
Completed Jobs sheet
I have created a code to move a row when a field is marked as 'Complete' to another sheet on a separate tab, however it will not move the row to the next available row on the other sheet, it moves it to the next available row outside of the table. Can you please assist? This is the code I have:
Sub MoveRowsToCompletedJobs()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim i As Long
' Set the source and target sheets
Set sourceSheet = ThisWorkbook.Worksheets("WIP REPORT (ACTIVE)")
Set targetSheet = ThisWorkbook.Worksheets("COMPLETED_JOBS")
' Find the last row in the source sheet
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "P").End(xlUp).Row
' Loop through each row in the source sheet
For i = 2 To lastRow
' Check if cell in column P contains "COMPLETED"
If sourceSheet.Cells(i, "P").Value = "COMPLETED" Then
' Copy the entire row to the target sheet
sourceSheet.Rows(i).Copy Destination:=targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Offset(1)
' Delete the row from the source sheet
sourceSheet.Rows(i).Delete
' Decrement the loop counter as the rows are shifting up
i = i - 1
' Update the last row value
lastRow = lastRow - 1
End If
Next i
End Sub
Tried the code above and whilst it moved the row to the second tab, it moves to the next available row outside of the table. Is it because one table has more columns than the other?
WIP Report active tab (source sheet)
Completed Jobs sheet
Share Improve this question edited Nov 21, 2024 at 21:16 Lil Faulkner asked Nov 21, 2024 at 7:08 Lil FaulknerLil Faulkner 311 silver badge2 bronze badges 2 |3 Answers
Reset to default 0Without changing the functionality of your code: you should not change the loop variable manually, that's what the for loop is, well, for.
Sub MoveRowsToCompletedJobs()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim lastRowTarget As Long
Dim i As Long
' Set the source and target sheets
Set sourceSheet = ThisWorkbook.Worksheets("WIP REPORT (ACTIVE)")
Set targetSheet = ThisWorkbook.Worksheets("COMPLETED_JOBS")
' Find the last row in the source sheet
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "P").End(xlUp).Row
' Loop through each row in the source sheet
For i = lastRow To 2 Step -1
' Check if cell in column P contains "COMPLETED"
If sourceSheet.Cells(i, "P").Value = "COMPLETED" Then
' Copy the entire row to the target sheet
lastRowTarget = targetSheet.Cells(sourceSheet.Rows.Count, "P").End(xlUp).Row
sourceSheet.Rows(i).Copy Destination:=targetSheet.Cells(lastRowTarget + 1, "A")
' Delete the row from the source sheet
sourceSheet.Rows(i).Delete
End If
Next i
End Sub
If an Excel table (ListObject) exists on targetSheet and includes column A, using End(xlUp) will always identify the last cell in column A within the table, regardless of whether it is blank or not.
Looping through the data rows in reverse order simplifies the code.
Sub MoveRowsToCompletedJobs()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long, targetCell As Range
Dim i As Long
' Set the source and target sheets
Set sourceSheet = ThisWorkbook.Worksheets("WIP REPORT (ACTIVE)")
Set targetSheet = ThisWorkbook.Worksheets("COMPLETED_JOBS")
' Find the last row in the source sheet
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "P").End(xlUp).Row
' Loop through each row in the source sheet
For i = lastRow To 2 Step -1
' Check if cell in column P contains "COMPLETED"
If sourceSheet.Cells(i, "P").Value = "COMPLETED" Then
' Copy the entire row to the target sheet
Set targetCell = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp)
If Len(targetCell.Value) = 0 Then
Set targetCell = targetCell.End(xlUp)
End If
sourceSheet.Rows(i).Copy Destination:=targetCell.Offset(1)
' Delete the row from the source sheet
sourceSheet.Rows(i).Delete
End If
Next i
End Sub
Move Matching Rows from One Excel Table to Another
- Not tested!
Sub MoveRowsToCompletedJobs()
Const SRC_SHEET_NAME As String = "WIP REPORT (ACTIVE)"
Const SRC_TABLE_ID As Variant = 1
Const SRC_CRITERIA_COLUMN As Long = 16
Const DST_SHEET_NAME As String = "COMPLETED_JOBS"
Const DST_TABLE_ID As Variant = 1
Const CRITERIA_STRING As String = "COMPLETED"
Application.ScreenUpdating = False
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source objects.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
Dim slo As ListObject: Set slo = sws.ListObjects(SRC_TABLE_ID)
Dim sRowsCount As Long: sRowsCount = slo.ListRows.Count
If sRowsCount = 0 Then
MsgBox "The source table is empty!", vbExclamation
Exit Sub
End If
If slo.ShowAutoFilter Then
If slo.AutoFilter.FilterMode Then slo.AutoFilter.ShowAllData
End If
Dim srg As Range: Set srg = slo.DataBodyRange
' Write the values from the source criteria column to an array.
Dim sData() As Variant
With srg.Columns(SRC_CRITERIA_COLUMN)
If sRowsCount = 1 Then
ReDim sData(1 To 1, 1 To 1)
sData(1, 1) = .Value
Else
sData = .Value
End If
End With
' Declare additional variables.
Dim surg As Range, r As Long, DeletedRowsCount As Long
' Loop through the rows of the array and combine the matching rows
' into a unioned range.
For r = 1 To sRowsCount
If CStr(sData(r, 1)) = CRITERIA_STRING Then
If surg Is Nothing Then
Set surg = srg.Rows(r)
Else
Set surg = Union(surg, srg.Rows(r))
End If
DeletedRowsCount = DeletedRowsCount + 1
End If
Next r
If Not surg Is Nothing Then
' Reference the destination objects.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
Dim dlo As ListObject: Set dlo = dws.ListObjects(DST_TABLE_ID)
If dlo.ShowAutoFilter Then
If dlo.AutoFilter.FilterMode Then dlo.AutoFilter.ShowAllData
End If
Dim drrg As Range: Set drrg = dlo.ListRows.Add.Range
' Copy and delete matching rows.
surg.Copy Destination:=drrg
surg.Delete xlShiftUp
End If
Application.ScreenUpdating = True
' Inform.
If DeletedRowsCount = 0 Then
MsgBox "No completed jobs found!", vbExclamation
Else
MsgBox DeletedRowsCount & " job" & IIf(DeletedRowsCount = 1, "", "s") _
& " moved to ""Completed Jobs"".", vbInformation
End If
End Sub
A:P)? Are there as many columns as in the table? Is the data in the source worksheet also in a table? If the data is contiguous (no empty rows or columns), you can reference the source range withDim srg As Range: Set srg = sourceSheet.Range("A1").CurrentRegion. Then you should copy the rows of the range instead of the entire rows of the worksheet. – VBasic2008 Commented Nov 21, 2024 at 9:03