Copy Matching Rows (Archive Data)
Before
After
Sub ArchiveData()
Const PROC_TITLE As String = "Archive Data"
Dim Msg As String
On Error GoTo ClearError ' out-comment if error message to troubleshoot!
Msg = "Defining constants"
' Source
Const SRC_SHEET_NAME As String = "Current"
Const SRC_COLUMNS As String = "A:E"
Const SRC_FIRST_ROW As Long = 2
Const SRC_SEARCH_COLUMN As Long = 4 ' n-th column of 'SRC_COLUMNS'!
Const SRC_SEARCH_STRING As String = "Done"
' Destination
Const DST_SHEET_NAME As String = "Archive"
Const DST_FIRST_CELL_ADDRESS As String = "A2"
' Other
Const MATCH_CASE As Boolean = False
Const DO_NOT_DELETE_ROWS As Boolean = True ' reset when finished testing!
Const SHOW_MESSAGES As Boolean = True
Msg = "Referencing the workbook"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Msg = "Retrieving source information"
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range, sfrg As Range, slcell As Range, sRowsCount As Long
With sws.Rows(SRC_FIRST_ROW).Columns(SRC_COLUMNS) ' first row
Set sfrg = .Resize(sws.Rows.Count - .Row + 1) ' find range
Set slcell = sfrg.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If slcell Is Nothing Then ' last non-empty cell by rows
If SHOW_MESSAGES Then
MsgBox "No data found in ""'" & sws.Name & "'!" _
& sfrg.Address(0, 0) & """!", vbExclamation
Exit Sub
End If
End If
sRowsCount = slcell.Row - .Row + 1
Set srg = .Resize(sRowsCount)
End With
Dim scrg As Range: Set scrg = srg.Columns(SRC_SEARCH_COLUMN) ' search range
Dim scData() As Variant:
If sRowsCount = 1 Then
ReDim scData(1 To 1, 1 To 1)
scData(1, 1) = scrg.Value
Else
scData = scrg.Value
End If
Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
If ColumnsCount < SRC_SEARCH_COLUMN Then
MsgBox "The source range ""'" & sws.Name & "'!" _
& srg.Address(0, 0) & """ has fewer than " & SRC_SEARCH_COLUMN _
& " columns!", vbExclamation, PROC_TITLE
Exit Sub
End If
Msg = "Combining matching rows into unioned range"
Dim CompareMethod As Long: CompareMethod = MATCH_CASE + 1
Dim surg As Range, srrg As Range, sValue As Variant
Dim sRow As Long, dRowsCount As Long, WasSearchStringFound As Boolean
For sRow = 1 To sRowsCount
sValue = scData(sRow, 1)
If Not IsError(sValue) Then
If StrComp(sValue, SRC_SEARCH_STRING, CompareMethod) = 0 Then
dRowsCount = dRowsCount + 1
Set srrg = srg.Rows(sRow)
If WasSearchStringFound Then
Set surg = Union(surg, srrg)
Else
Set surg = srrg
WasSearchStringFound = True
End If
End If
End If
Next sRow
If Not WasSearchStringFound Then
If SHOW_MESSAGES Then
MsgBox "No rows with """ & SRC_SEARCH_STRING & """ in ""'" _
& sws.Name & "'!" & scrg.Address(0, 0) & """ found!", _
vbExclamation, PROC_TITLE
End If
Exit Sub
End If
Msg = "Retrieving destination information"
Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
If dws.FilterMode Then dws.ShowAllData
Dim drg As Range, dfrg As Range, dlcell As Range, dRowOffset As Long
With dws.Range(DST_FIRST_CELL_ADDRESS).Resize(, ColumnsCount) ' first row
Set dfrg = .Resize(dws.Rows.Count - .Row + 1) ' find range
Set dlcell = dfrg.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not dlcell Is Nothing Then ' last non-empty cell by rows
dRowOffset = dlcell.Row - .Row + 1
End If
Set drg = .Offset(dRowOffset).Resize(dRowsCount)
End With
Msg = "Archiving rows"
surg.Copy Destination:=drg
Dim sAddress As String: sAddress = srg.Address(0, 0)
Dim scAddress As String: scAddress = scrg.Address(0, 0)
If Not DO_NOT_DELETE_ROWS Then surg.Delete Shift:=xlShiftUp
Msg = "Informing"
If SHOW_MESSAGES Then
MsgBox dRowsCount & " row" & IIf(dRowsCount = 1, "", "s") & " of ""'" _
& sws.Name & "'!" & sAddress & """ with """ _
& SRC_SEARCH_STRING & """ in """ & scAddress & " " _
& IIf(DO_NOT_DELETE_ROWS, "copie", "move") & "d to ""'" _
& dws.Name & "'!" & drg.Address(0, 0) & """.", _
vbInformation, PROC_TITLE
End If
ProcExit:
Exit Sub
ClearError: ' e.g. not enough rows in the destination sheet
MsgBox "Run-time error [" & Err.Number & "]: (while " & LCase(Msg) & ")" _
& vbLf & vbLf & Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Sub