Copy sheet and add Location number

[kenpcli]

I am trying get a macro to look down column A and each change in site name add their location number underneath it.

		Chg Amt	Pay Amt	Adj Amt	Ref Amt	Bal Amt
Albuquerque
60	Totals For AETNA	$51,896.00	-$31,204.59	-$19,152.69	$164.35	$1,703.07
60	Totals For BCBS	$659,678.00	-$320,482.96	-$324,294.18	$7,687.05	$22,587.91
60	Totals For CIGNA	$264.00	-$211.20	-$52.80	$0.00	$0.00
60	Totals For COMMERCIAL	$20,122.00	-$13,354.59	-$4,563.70	$0.00	$2,203.71
60	Totals For DSHS	$8,573.00	-$4,020.36	-$60.64	$0.00	$4,492.00
60	Totals For FCHN	$3,774.00	-$2,868.21	-$905.79	$0.00	$0.00
60	Totals For HUMANA	$309.00	-$167.12	-$141.88	$0.00	$0.00
60	Totals For IPN	$3,923.00	-$2,678.76	-$1,244.24	$0.00	$0.00
60	Totals For MEDICAID COMMERCIAL	$115,651.00	-$41,467.85	-$57,352.41	$498.51	$17,329.25
60	Totals For MEDICARE	$1,928,300.00	-$849,877.14	-$1,015,188.85	$3,064.69	$66,298.70
60	Totals For MEDICARE ADVANTAGE	$440,932.00	-$175,505.21	-$210,678.60	$2,942.08	$57,690.27
60	Totals For MEDICARE RR	$37,253.00	-$15,900.45	-$20,182.52	$0.00	$1,170.03
60	Totals For MOLINA	$0.00	$0.00	$0.00	$0.00	$0.00
60	Totals For MULTIPLAN	$9,156.00	-$4,661.86	-$1,026.14	$0.00	$3,468.00
60	Totals For SELF PAY	$80,687.75	-$38,452.48	-$37,242.02	$149.40	$5,142.65
60	Totals For TRICARE	$39,590.00	-$18,544.17	-$12,423.73	$921.20	$9,543.30
60	Totals For UNITED HEALTHCARE	$237,266.00	-$153,616.60	-$65,164.26	$1,515.56	$20,000.70
60	Totals For VETERANS ADMIN	$23,748.00	-$10,461.24	-$10,419.76	$0.00	$2,867.00
Totals For Albuquerque		$3,661,122.75	-$1,683,474.79	-$1,780,094.21	$16,942.84	$214,496.59
Bellevue
30	Totals For AETNA	$504,981.00	-$312,837.07	-$173,143.99	$8,490.26	$27,490.20
30	Totals For CIGNA	$201,832.00	-$137,141.51	-$43,931.99	$546.69	$21,305.19

<colgroup><col><col><col><col span="2"><col><col></colgroup><tbody>
</tbody>

 

[Fluff]

Hi, give this a go

Sub FillDownLookup()

    Dim Ar As Areas
    Dim Rng As Range
    Dim ValU As Long
    
    With Sheets("[COLOR=#ff0000]Roster[/COLOR]")
        Set Ar = .Range("A2:A" & .Range("C" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).Areas
        For Each Rng In Ar
            Rng.Value = Evaluate("VLookup(" & Rng.Offset(-1).Resize(1).Address & ",'[COLOR=#ff0000]list[/COLOR]'![COLOR=#0000ff]A1:B1000[/COLOR], 2, False)")
        Next Rng
    End With
    
End Sub

Change the sheet names in red to suit, as well as the lookup range in blue.
If you don't already have one, you'll need to create a lookup list With the Sites in Column A & the number in column. This needs to be sorted alphabetically.

 

[kenpcli]

Thank you, worked like a charm.

 

[Fluff]

Glad to help & thanks for the feedback

 

[kenpcli]

How would you to then get it to do the following:

Insert column before A

<tbody>
</tbody>

Sort by site, remove all but site numbers Add formulas to A, I, J make sure J has the iferror formula. Sort by INS Company Cut and place at bottom, NO INSURANCE & SELF PAY sum AND add TOTAL LINES Verify alalysis totals <tbody> </tbody> <tbody> </tbody> <tbody> </tbody> <tbody> </tbody> <tbody> </tbody>

<tbody>
</tbody>

 

[Fluff]

This will do the 1st two items

Sub FillDownLookup()

    Dim Ar As Areas
    Dim Rng As Range
    Dim ValU As Long
    
    With Sheets("Roster")
        Set Ar = .Range("A2:A" & .Range("C" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).Areas
        For Each Rng In Ar
            Rng.Value = Evaluate("VLookup(" & Rng.Offset(-1).Resize(1).Address & ",'list'!A1:B1000, 2, False)")
        Next Rng
        .Columns(1).Insert
        With Columns(2)
            .SpecialCells(xlConstants, xlTextValues).EntireRow.Delete
        End With
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("B2", .Range("B" & Rows.Count).End(xlUp)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("B1:H" & Range("B" & Rows.Count).End(xlUp).Row)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
End Sub

As for the rest you have supplied insufficient info for me to able to help.

 

[kenpcli]

This will do the 1st two items

Sub FillDownLookup()

    Dim Ar As Areas
    Dim Rng As Range
    Dim ValU As Long
    
    With Sheets("Roster")
        Set Ar = .Range("A2:A" & .Range("C" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).Areas
        For Each Rng In Ar
            Rng.Value = Evaluate("VLookup(" & Rng.Offset(-1).Resize(1).Address & ",'list'!A1:B1000, 2, False)")
        Next Rng
        .Columns(1).Insert
        With Columns(2)
            .SpecialCells(xlConstants, xlTextValues).EntireRow.Delete
        End With
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("B2", .Range("B" & Rows.Count).End(xlUp)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("B1:H" & Range("B" & Rows.Count).End(xlUp).Row)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
End Sub

As for the rest you have supplied insufficient info for me to able to help.

it does like the ".SpecialCells(xlConstants, xlTextValues).EntireRow.Delete"

 

[Fluff]

Sorry, I don't understand.
Are you saying that it works, or that it doesn't?

 

[kenpcli]

Yes it does not work, it errors on this line:
".SpecialCells(xlConstants, xlTextValues).EntireRow.Delete"

This is the original script I was given:
Sub FillDownLookup()
Dim Ar As Areas
Dim Rng As Range
Dim ValU As Long

With Sheets("Analysis")
Set Ar = .Range("A6:A" & .Range("C" & Rows.Count).End(xlUp).row).SpecialCells(xlBlanks).Areas
For Each Rng In Ar
Rng.Value = Evaluate("VLookup(" & Rng.Offset(-1).Resize(1).Address & ",'LEGEND SITE'!A1:B20, 2, False)")
Next Rng
.Columns(1).Insert
With Columns(2)
.SpecialCells(xlConstants, xlTextValues).EntireRow.Delete
End With
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("C6", .Range("C" & Rows.Count).End(xlUp)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("B6:H" & Range("B" & Rows.Count).End(xlUp).row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub

Thanks

 

[kenpcli]

Yes it does not work, it errors on this line:
".SpecialCells(xlConstants, xlTextValues).EntireRow.Delete"

This is the original script I was given:
Sub FillDownLookup()
Dim Ar As Areas
Dim Rng As Range
Dim ValU As Long

With Sheets("Analysis")
Set Ar = .Range("A6:A" & .Range("C" & Rows.Count).End(xlUp).row).SpecialCells(xlBlanks).Areas
For Each Rng In Ar
Rng.Value = Evaluate("VLookup(" & Rng.Offset(-1).Resize(1).Address & ",'LEGEND SITE'!A1:B20, 2, False)")
Next Rng
.Columns(1).Insert
With Columns(2)
.SpecialCells(xlConstants, xlTextValues).EntireRow.Delete
End With
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("C6", .Range("C" & Rows.Count).End(xlUp)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("B6:H" & Range("B" & Rows.Count).End(xlUp).row)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub

Thanks

Also the fill in is coming up with the wrong site number off the legend.