Help with VBA Code

[cmschmitz24]

Hello,
My VBA code works fine, however it copy/pastes my header into a new row and I'm not sure why or where to fix it in the code. Can someone please review and update it for me? I tried and was unsuccessful.

Sub BBDelLapseCancel()
'
' BBDelLapseCancel Macro
'
    Dim a(), af, rws
    Dim i As Long
    Dim c As Integer
    Dim lr As Long
    Dim r As Long

'
    'removes unneeded columns
    Columns("B:D").Delete Shift:=xlToLeft
    Columns("C:C").Delete Shift:=xlToLeft
    Columns("E:H").Delete Shift:=xlToLeft
    Columns("G:N").Delete Shift:=xlToLeft
    Columns("G:J").Cut
    Columns("E:E").Insert Shift:=xlToRight
    
    'sorts by campus, emplid, and plan type
    ActiveWorkbook.Worksheets("Lapse-Cancel").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Lapse-Cancel").Sort.SortFields.Add2 Key:=Range( _
        "B2:B31"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Lapse-Cancel").Sort.SortFields.Add2 Key:=Range( _
        "C2:C31"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Lapse-Cancel").Sort.SortFields.Add2 Key:=Range( _
        "I2:I31"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Lapse-Cancel").Sort
        .SetRange Range("A1:J31")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'removes duplicates
    lr = Cells(Rows.Count, "C").End(xlUp).Row
    
    For r = lr To 2 Step -1
        If (Cells(r, "C") = Cells(r - 1, "C")) And (Cells(r, "I") = Cells(r - 1, "I")) Then
            Rows(r).Delete
        End If
    Next r
    
 
    'adds columns
    Columns("B:B").Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    
    'adds headder text
    Range("B1").Value = "Letter Language"
    Range("C1").Value = "Campus"
    Range("J1").Value = "Non Payment Paid Through Date"
    Range("K1").Value = "Notes"
    Range("L1").Value = "BB Amnt Due"
    Range("M1").Value = "BB Due Date"
    Range("N1").Value = "BB Paid Through Date"
    Range("P1").Value = "Description 1"
    
    'copies headders over
    Range("O1:P1").Select
    Selection.Copy
    Range("Q1").Select
    ActiveSheet.Paste
    Range("S1").Select
    ActiveSheet.Paste
    Range("U1").Select
    ActiveSheet.Paste
    Range("W1").Select
    ActiveSheet.Paste
    Range("Y1").Select
    ActiveSheet.Paste
    Range("AA1").Select
    ActiveSheet.Paste
    Range("AC1").Select
    ActiveSheet.Paste
    Range("AE1").Select
    ActiveSheet.Paste
    Range("AG1").Select
    ActiveSheet.Paste
    Range("AI1").Select
    ActiveSheet.Paste
    Range("AK1").Select
    ActiveSheet.Paste
    Range("AM1").Select
    ActiveSheet.Paste
    Range("AO1").Select
    ActiveSheet.Paste
    Range("AQ1").Select
    ActiveSheet.Paste
    
    'updates headder text
    Range("R1").Value = "Description 2"
    Range("T1").Value = "Description 3"
    Range("V1").Value = "Description 4"
    Range("X1").Value = "Description 5"
    Range("Z1").Value = "Description 6"
    Range("AB1").Value = "Description 7"
    Range("AD1").Value = "Description 8"
    Range("AF1").Value = "Description 9"
    Range("AH1").Value = "Description 10"
    Range("AJ1").Value = "Description 11"
    Range("AL1").Value = "Description 12"
    Range("AM1").Value = "Description 13"
    Range("AP1").Value = "Description 14"
    Range("AR1").Value = "Description 15"
    
    'aranges columns to center alignment
    Columns("Q:Q").HorizontalAlignment = xlCenter
    Columns("S:S").HorizontalAlignment = xlCenter
    Columns("U:U").HorizontalAlignment = xlCenter
    Columns("W:W").HorizontalAlignment = xlCenter
    Columns("Y:Y").HorizontalAlignment = xlCenter
    Columns("AA:AA").HorizontalAlignment = xlCenter
    Columns("AC:AC").HorizontalAlignment = xlCenter
    Columns("AE:AE").HorizontalAlignment = xlCenter
    Columns("AG:AG").HorizontalAlignment = xlCenter
    Columns("AI:AI").HorizontalAlignment = xlCenter
    Columns("AK:AK").HorizontalAlignment = xlCenter
    Columns("AM:AM").HorizontalAlignment = xlCenter
    Columns("AO:AO").HorizontalAlignment = xlCenter
    Columns("AP:AP").HorizontalAlignment = xlCenter
    
    'letter language vlookup
    Range("K2").Value = "Because your coverage has been cancelled due to non-payment, this is considered a voluntary cancellation and you will not have COBRA/Continuation rights. The insurance will remain cancelled until your next enrollment opportunity during the Annual Benefits Enrollment period for coverage effective January 1st or through a qualifying life event."
    Range("L2").Value = "Because your coverage has been lapsed due to non-payment while on an unpaid LOA, you may be eligible to re-enroll in coverage upon returning to work. You will have 30 calendar days from the day you return to work to submit application(s) to your Benefits Office in order to re-enroll in any lapsed benefit plan. If you do not re-enroll within 30 calendar days upon returning to work, your next enrollment opportunity will be during the Annual Benefits Enrollment period for coverage effective January 1st or through a qualifying life event. There are no interim re-enrollment opportunities."
    Range("K2:L2").Select
    Selection.AutoFill Destination:=Range("K2:L" & Cells(Rows.Count, "C").End(xlUp).Row)
    
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]=""Lapse due to non-payment"", RC[10],RC[9])"
    Range("B2").Select
    Selection.AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, "C").End(xlUp).Row)
    
    'copy/paste values for letter language
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Range("K2:L30").ClearContents
        
    Cells.EntireColumn.AutoFit
    Columns("B:B").ColumnWidth = 14
    Columns("K:K").ColumnWidth = 14
    
    Columns("D:D").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Selection.Cut
    Columns("C:C").Select
    Columns("E:E").Select
    Application.CutCopyMode = False
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
          
          
    'merges employees into 1 row
    With Sheets("Lapse-Cancel").[A1].CurrentRegion
        a = .Value
        ReDim af(1 To UBound(a), 1 To 200)
        ReDim rws(1 To UBound(a))
        
        For i = 2 To UBound(a)
            If a(i, 1) = a(i - 1, 1) Then
                c = c + 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            Else
                r = r + 1
                rws(r) = i
                c = 1
                af(r, c) = a(i, 15)
                c = c + 1
                af(r, c) = a(i, 16)
            End If
        Next
        ReDim Preserve rws(1 To r)
        rws = Application.Transpose(rws)
        With .Offset(1, 0)
            .ClearContents
            .Resize(r, 14) = Application.Index(a, rws, Application.Transpose(Evaluate("Row(1:" & 14 & ")")))
            .Offset(, 14).Resize(r, UBound(af, 2)).Value = af
        End With
    End With
    
    Columns("A:A").NumberFormat = "00000000"
    Range("A2").Select

End Sub

Here's what the output looks like. Row 2 shouldn't be there but I can't figure out how to fix it. I think the code is the last section, "merges employees into 1 row"

 

[offthelip]

I notice that you are not reinitialising the index r which you used in a reverse loop ending on 2 when deleting rows. so try setting r to 1 just before these lines:

'merges employees into 1 row
r= 1   ' add this line
    With Sheets("Lapse-Cancel").[A1].CurrentRegion

 

[cmschmitz24]

Thank you, however the output still duplicates the header with adding the index r as you stated.