Help with VBA Code

cmschmitz24

Board Regular
Joined
Jan 27, 2017
Messages
128
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.

VBA Code:
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"
1614972454022.png
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,820
Office Version
  1. 2010
Platform
  1. Windows
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:
VBA Code:
'merges employees into 1 row
r= 1   ' add this line
    With Sheets("Lapse-Cancel").[A1].CurrentRegion
 

cmschmitz24

Board Regular
Joined
Jan 27, 2017
Messages
128
Thank you, however the output still duplicates the header with adding the index r as you stated.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,104
Messages
5,640,128
Members
417,126
Latest member
Jeffman52

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top