Sub NewSupp() Dim lRow, NewSuppRow As Long, Sheet2 As Worksheet Set Sheet2 = Sheets("Blad2") lRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row NewSuppRow = Application.WorksheetFunction.RoundDown((((lRow - 2) / 8) + 2), 0) * 8 - 6 Range("B2:B4").Copy Sheet2.Range("A" & NewSuppRow).PasteSpecial Transpose:=True Range("B10:B18").Copy Sheet2.Range("D" & NewSuppRow).PasteSpecial Transpose:=True Range("B2:B4", "B9:B18").ClearContents End Sub
Sub UpdateSupp() Dim mFind As Range, Sheet2 As Worksheet, x As Long Set Sheet2 = Sheets("Blad2") Set mFind = Sheet2.Columns("C").Find(Range("B4")) Do x = x + 1 If x = 8 Then MsgBox "There is no room for a new update" Exit Sub End If If mFind.Offset(x, 0) = vbNullString Then Exit Do Loop Range("B2:B4").Copy Sheet2.Range("A" & mFind.Row + x).PasteSpecial Transpose:=True Range("B10:B18").Copy Sheet2.Range("D" & mFind.Row + x).PasteSpecial Transpose:=True Range("B2:B4", "B9:B18").ClearContents End Sub
DON'T MISS