by Bradz89 » Tue Jan 17, 2023 1:13 pm
You could try this - it was provided by ChatGPT
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("aa5:aa10")) Is Nothing Then
Dim count As Integer
count = 0
For i = 5 To 10
If Range("aa" & i).Value > 0 Then
count = count + 1
End If
Next i
Range("aa1").Value = count
If Range("aa1").Value > 1 Then
Dim lastColumn As Long
lastColumn = Cells(5, Columns.Count).End(xlToLeft).Column + 1
Range("z5:z10").Copy Destination:=Cells(5, lastColumn)
End If
End If
End Sub