VBA Macro to Shift Cell range Up Based on Transaction Boundary Conditions in Excel

Question

I'm working with a dataset in Excel that represents journal entries, and I'm encountering an issue where parts of a transaction are on the wrong row. I need a VBA macro that can identify the start of a transaction, find all related rows that belong to it, and shift these rows up to align correctly with the transaction's starting point.

The transaction data follows these rules:

• A new transaction starts with a non-empty 'journal_id' in column I.
• All related rows below this and up to the next non-empty 'journal_id' are considered part of the transaction.
• The related rows always have an empty 'journal_id'.

The challenge is:

• Some transactions are correctly aligned, and others are not.
• The macro should only shift the range up that are part of a misaligned transaction.
• Transactions consist of multiple range rows, and I need to shift the entire block with the mentioned range on the script, not just the first row following the transaction start.

Current Macro Behavior:

• The current macro I'm using is inconsistently identifying the transactions. It sometimes correctly shifts range up, but other times it misses some lines or only shifts the first related row range, and delete the rest of the transaction related lines.

Example of Issue:

• Line 9 and 10 are correctly aligned.
• Line 12 is misaligned and been deleted while it should be shifted up, but it's missed by the macro.
• Line 13 is correctly aligned and shifted.

Please note:

• Image 1 is the original view of the file
• Image 2 is the macro result

Here's the core part of the macro I'm using:

Sub HighlightAndFixGlitches()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Clean Journals") ' Change to your actual sheet name if different

Dim lastRow As Long
Dim startRow As Long
Dim endRow As Long
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False ' Disable screen updating for performance

With ws
    lastRow = .Cells(.Rows.Count, "I").End(xlUp).row ' Assuming column I ('journal_id') indicates new transactions

    ' Loop through each row from bottom to top
    For i = lastRow To 2 Step -1
        ' Highlight the row if 'invoice_date', 'payment_reference', 'journal_id' are filled and 'account_id' is empty
        If Not IsEmpty(.Cells(i, "I")) And IsEmpty(.Cells(i, "T")) Then
            .Rows(i).Interior.Color = RGB(255, 0, 0) ' Highlight in red

            ' Find the start and end of the current transaction block
            startRow = i
            endRow = i
            While IsEmpty(.Cells(startRow - 1, "I")) And startRow > 2
                startRow = startRow - 1
            Wend
            While IsEmpty(.Cells(endRow + 1, "I")) And endRow < lastRow
                endRow = endRow + 1
            Wend

            ' Shift all rows from startRow to endRow up by one row
            For j = startRow To endRow
                .Range(.Cells(j + 1, "K"), .Cells(j + 1, "AJ")).Copy
                .Range(.Cells(j, "K"), .Cells(j, "AJ")).PasteSpecial Paste:=xlPasteValues
                .Range(.Cells(j + 1, "K"), .Cells(j + 1, "AJ")).ClearContents
            Next j

            ' We need to skip the shifted block to avoid reprocessing
            i = startRow - 1
        End If
    Next i
End With

Application.CutCopyMode = False ' Clear clipboard
Application.ScreenUpdating = True ' Re-enable screen updating
End Sub

I suspect the issue might be related to how I'm identifying the transaction blocks or perhaps in the loop logic that shifts the rows.

My question is:

How can I adjust my VBA macro to consistently identify the full block of rows for each transaction and shift them up correctly without affecting the already aligned transactions?

Answer 1

Your code is close to finish.

• Get lastRow by the content in column A
• Assigning value to a range (cells) is more efficient than copy-paste

Option Explicit

Sub HighlightAndFixGlitches()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Clean Journals") ' Change to your actual sheet name if different
    Dim lastRow As Long
    Dim endRow As Long
    Dim i As Long
    Dim j As Long
     Application.ScreenUpdating = False ' Disable screen updating for performance
    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' Assuming column I ('journal_id') indicates new transactions
        endRow = 0
        ' Loop through each row from bottom to top
        For i = lastRow To 2 Step -1
            If IsEmpty(.Cells(i, "I")) Then
                If endRow = 0 Then endRow = i
            Else
                If IsEmpty(.Cells(i, "T")) Then
                    .Rows(i).Interior.Color = RGB(255, 0, 0) ' Highlight in red
                    For j = i To endRow - 1
                        .Range(.Cells(j, "K"), .Cells(j, "AJ")).Value = .Range(.Cells(j + 1, "K"), .Cells(j + 1, "AJ")).Value
                    Next j
                    .Range(.Cells(endRow, "K"), .Cells(endRow, "AJ")).ClearContents
                End If
                endRow = 0
            End If
        Next i
    End With
    Application.ScreenUpdating = True ' Re-enable screen updating
End Sub

Answer 2

Here's the code which should do the trick. You have to update the range to copy according to your data: Range(sht.Cells(i + 1, 10), sht.Cells(i + j, 21)).Cut sht.Cells(i, 10) - the last cell here is sht.Cells(i + j, 21) which is an equivalent for the column U.

Dim sht As Worksheet

Set sht = ThisWorkbook.Sheets("Clean Journals")

Dim lRow As Long, i As Long, j As Integer
' get the last row in column "journal_id"
lRow = sht.Cells(Rows.Count, 9).End(xlUp).Row

' looping through the "journal_id" column from Top to Bottom
For i = 2 To lRow
    ' identifying shifted data: "journal_id" is not empty and "invoice_line_ids/account_ids"
    ' is empty (column T in your file)
    If Not sht.Cells(i, 9).Value = "" And sht.Cells(i, 20) = "" Then
            ' assigning variable to jump 1 row below to find out
            ' how many rows in this transaction
            j = 1
            ' looping through column "invoice_line_ids/account_ids" (T)
            ' until "journal_id" is empty and it is not
            Do While sht.Cells(i + j, 4).Value = "" And Not sht.Cells(i + j, 7).Value = ""
                j = j + 1
            Loop
            
        ' removing one row jump to bottom
        j = j - 1
        
        ' moving the range with needed data to its place,
        ' depending on number of rows in transaction
        Range(sht.Cells(i + 1, 10), sht.Cells(i + j, 21)).Cut sht.Cells(i, 10)
        
        ' removing the blank row, which is left after we moved data
        sht.Cells(i + j, 1).EntireRow.Delete
        
        ' re-determining the last row because we have deleted some of them
        ' one step up
        lRow = sht.Cells(Rows.Count, 9).End(xlUp).Row
    End If
Next