Help with VBA Code in Excel

[tixarah]

I have an excel workbook for work that I am trying to get to work properly but the code doesnt do exactly what I want yet.

Right now I have it working within 3 sheets. Fifo Tracking, Mileage History, and Drivers

The parts of the code that are not working is from the Fifo Tracking sheet, when I delete a truck number it is supposed to transfer all that data to mileage history and then delete the row. It does this, however it does NOT move the truck number, and when you delete the next truck number it overwrites the old data and doesnt move to the next line. I've added the code I am using below as well.

Please help!!

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo SafeExit

    ' Check if the change happened in column B (Truck Number) and if it's in row 2 to 50
    If Not Intersect(Target, Me.Range("B2:B50")) Is Nothing Then
        ' If a truck number is entered, run AutoPopulate
        If Target.Value <> "" Then
            Call AutoPopulate
        End If

        ' If a truck number is deleted, move the data to "Mileage History" and delete the row
        If Target.Value = "" Then
            Call TransferAndDelete(Target)
        End If
    End If

    ' Re-apply row colors based on PTA dates
    Call ApplyRowColors

    ' Auto-sort the data by column F and then by column H
    Call AutoSort

SafeExit:
    ' Ensure events are enabled, in case they were disabled earlier
    Application.EnableEvents = True
End Sub

Private Sub AutoPopulate()
    Dim wsDrivers As Worksheet
    Dim rngFound As Range
    Dim truckNumber As String
    Dim cell As Range

    ' Disable events to avoid triggering the macro again while populating data
    Application.EnableEvents = False

    ' Define the Drivers sheet
    Set wsDrivers = ThisWorkbook.Sheets("Drivers")
   
    ' Loop through the cells in the Fifo Tracking sheet in column B (rows 2 to 50)
    For Each cell In Me.Range("B2:B50")
        If cell.Value <> "" Then
            ' Trim any leading or trailing spaces from the truck number
            truckNumber = Trim(cell.Value)
           
            ' Find the truck number in the Drivers sheet
            Set rngFound = wsDrivers.Range("A:A").Find(What:=truckNumber, LookIn:=xlValues, LookAt:=xlWhole)
           
            ' If truck number is found, auto-populate Alpha Code, Fast, and Home Terminal
            If Not rngFound Is Nothing Then
                cell.Offset(0, 1).Value = rngFound.Offset(0, 1).Value ' Alpha Code
                cell.Offset(0, 2).Value = rngFound.Offset(0, 2).Value ' Fast
                cell.Offset(0, 3).Value = rngFound.Offset(0, 3).Value ' Home Terminal
            Else
                ' Clear values if the truck number is not found
                cell.Offset(0, 1).ClearContents
                cell.Offset(0, 2).ClearContents
                cell.Offset(0, 3).ClearContents
            End If
        End If
    Next cell

    ' Re-enable events after the operation is complete
    Application.EnableEvents = True
End Sub

Private Sub TransferAndDelete(ByVal Target As Range)
    Dim wsMileageHistory As Worksheet
    Dim nextRow As Long

    ' Disable events to avoid triggering the macro again while transferring data
    Application.EnableEvents = False

    ' Define the Mileage History sheet
    Set wsMileageHistory = ThisWorkbook.Sheets("Mileage History")

    ' Find the next empty row in Mileage History, starting from row 2
    If Application.WorksheetFunction.CountA(wsMileageHistory.Cells) = 0 Then
        nextRow = 2 ' If the sheet is empty, start at row 2
    Else
        nextRow = wsMileageHistory.Cells(wsMileageHistory.Rows.Count, 1).End(xlUp).Row + 1
        ' Ensure we start at row 2
        If nextRow < 2 Then nextRow = 2
    End If

    ' Copy columns B to H (Truck Number and other data) from Fifo Tracking to Mileage History
    wsMileageHistory.Range("B" & nextRow & ":H" & nextRow).Value = Me.Range("B" & Target.Row & ":H" & Target.Row).Value
   
    ' Delete the row in Fifo Tracking after transferring the data
    Me.Rows(Target.Row).Delete

    ' Re-enable events after the operation is complete
    Application.EnableEvents = True
End Sub

Private Sub AutoSort()
    ' Disable events to avoid triggering the macro again during sorting
    Application.EnableEvents = False
   
    ' Sort data from row 2 onwards, by column F (Oldest to Newest) and then by column H (smallest to largest)
    Me.Sort.SortFields.Clear
    Me.Sort.SortFields.Add Key:=Range("F2:F50"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Me.Sort.SortFields.Add Key:=Range("H2:H50"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   
    With Me.Sort
        .SetRange Me.Range("B2:J50") ' Set the range to sort (B to J, rows 2 to 50)
        .Header = xlNo ' Exclude header row
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    ' Re-enable events after the operation is complete
    Application.EnableEvents = True
End Sub

Private Sub ApplyRowColors()
    Dim rng As Range
    Dim cell As Range
    Dim ptaDate As Variant

    ' Disable events while applying colors to avoid triggering other macros
    Application.EnableEvents = False
   
    ' Define the range (B2 to J50) to apply color
    Set rng = Me.Range("B2:J50")

    ' Loop through each row and apply color based on the PTA date (Column G)
    For Each cell In rng.Columns(6).Cells ' Column G for PTA date
        ptaDate = cell.Value
        If IsDate(ptaDate) Then
            ' If the PTA date is later than today, color the row grey (only B to J)
            If ptaDate > Date Then
                Me.Range("B" & cell.Row & ":J" & cell.Row).Interior.Color = RGB(211, 211, 211) ' Light Grey
            Else
                ' Clear color if the PTA date is today or earlier
                Me.Range("B" & cell.Row & ":J" & cell.Row).Interior.ColorIndex = xlNone
            End If
        End If
    Next cell
   
    ' Re-enable events after coloring rows
    Application.EnableEvents = True
End Sub

 

[Skyybot]

Try replacing this code:

' Find the next empty row in Mileage History, starting from row 2
If Application.WorksheetFunction.CountA(wsMileageHistory.Cells) = 0 Then
nextRow = 2 ' If the sheet is empty, start at row 2
Else
nextRow = wsMileageHistory.Cells(wsMileageHistory.Rows.Count, 1).End(xlUp).Row + 1
' Ensure we start at row 2
If nextRow < 2 Then nextRow = 2
End If

With this and see if it works. Please remember to test this on a COPY of your Workbook!

' Find the next empty row in Mileage History, starting from row 2
nextRow = wsMileageHistory.UsedRange.Rows.Count +1

 

[tixarah]

Thank you! Got this working now!