Copy sheet and add Location number

K

kenpcli

Board Regular
Joined
Oct 24, 2017
Messages
129
I am trying get a macro to look down column A and each change in site name add their location number underneath it.

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

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Hi, give this a go
Code: 
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.
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
How would you to then get it to do the following:

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]Insert column before A[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]Sort by site, remove all but site numbers

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]Add formulas to A, I, J make sure J has the iferror formula.

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]Sort by INS Company

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]Cut and place at bottom, NO INSURANCE & SELF PAY

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]sum AND add TOTAL LINES

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]Verify alalysis totals[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
This will do the 1st two items
Code: 
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.
 
Upvote 0
Fluff said:
This will do the 1st two items
Code: 
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.
Click to expand...

it does like the ".SpecialCells(xlConstants, xlTextValues).EntireRow.Delete"
 
Upvote 0
Sorry, I don't understand.
Are you saying that it works, or that it doesn't?
 
Upvote 0
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
 
Upvote 0
kenpcli said:
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
Click to expand...

Also the fill in is coming up with the wrong site number off the legend.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Fill and Sort
2
Replies
12
Views
1K
Fluff
Fluff

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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
Back
Top