The company I work for keeps track of malfunctions in a source sheet called "Storingen" (malfunctions). Whenever the malfunction has been dealt with, they change the status (in column D) to "Opgelost" (solved). Once a week we discuss every malfunction and when this meeting is over, I want to press a button to copy all the rows with data about the malfuctions who have been solved to a worksheet called "Archief" (archive). I want the data to be copied to the first empty row in the sheet, so no empty rows are created and everything is copied to the archive in a chronological order. Always the latest data at the bottom row. The copied data needs to be removed from the source sheet, leaving only the rows that where not dealt with. So we always have a clear view of what still needs to be done. I want to remove all empty rows where once the -copied/now deleted- rows where.
I have tried to make a sub that copies all the data, and this works fine for me (I put it in the block below). But I just cannot seem to grasp how I do all the other things that I just described. I have tried advanced filtering and random bits of coding from the internet. But I can't seem to get i to work
Sub Archiveer()
If MsgBox("Wil je deze data archiveren?", vbOKCancel, "Let op!") = vbOK Then
Sheets("Archief").Unprotect Password:="Smits"
Worksheets("Storingen").Select
Range("3:100").Copy
Worksheets("Archief").Activate
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Worksheets("Storingen").Select
Range("3:100").ClearContents
Cells(Rows.Count, "A").End(xlUp).Offset(2, 0).Select
Sheets("Archief").Protect Password:="Smits"
Else
Exit Sub
End If
End Sub
If anyone can help me, it would be greatly appreciated!
Iterate through the source table to check the values in column D, copy the matching rows to the target sheet, and delete all matched rows in a single operation at the end.
Microsoft documentation:
Sub MoveRowsToCompletedJobs()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long, targetCell As Range
Dim i As Long, ColCnt As Long, delRng As Range
Const KEY_COL = "D" ' modify as needed
Const FIRST_DATA_ROW = 3 ' modify as needed
' Set the source and target sheets
Set sourceSheet = ThisWorkbook.Worksheets("Storingen")
Set targetSheet = ThisWorkbook.Worksheets("Archief")
' Find the last row in the source sheet
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, KEY_COL).End(xlUp).Row
ColCnt = sourceSheet.UsedRange.Columns.Count
' Loop through each row in the source sheet
For i = lastRow To FIRST_DATA_ROW Step -1
' Check if cell in column D contains "Opgelost"
If sourceSheet.Cells(i, KEY_COL).Value = "Opgelost" Then
' Copy the data row to the target sheet
Set targetCell = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp)
' If Excel table (ListObject) on the target sheeet, get the target cell in table
If Len(targetCell.Value) = 0 Then
Set targetCell = targetCell.End(xlUp)
End If
sourceSheet.Cells(i, 1).Resize(, ColCnt).Copy Destination:=targetCell.Offset(1)
' collect cells to delete at the end
If delRng Is Nothing Then
Set delRng = sourceSheet.Cells(i, 1)
Else
Set delRng = Union(delRng, sourceSheet.Cells(i, 1))
End If
End If
Next i
If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If
End Sub