VBA- cleaning up code/making it more efficient

ffionnah

Board Regular
Joined
Jun 12, 2018
Messages
61
Hi everyone,
Thank you, in advance, for any help!


I jumbled together this code which does what I want, however, it is very slow. Could you please help me to identify how I can make this more efficient and effective?

I have multiple spreadsheets with similar and different data, that needs to be all organized under the same headers. Most of the datasets have different headers, so I need to rename headers before moving columns. Anything that is different from the headers I am purposefully organizing, will be moved to the end of the columns.


Focused headers, in this order:
"Unqiue ID", "PATFRSNME", "PATLSTNME", "DOB", "PT ID", "Rx Number", "Date Submitted", "Written Date", "Refill", "Cont Phar(Y/N)", "ccc Location (Y/N)", "In Scope? (Y/N)", "EMR", "Encounter Date", "NDC", "Description", "Qty", "BIN", "PCN", "GROUPID", "Payer", "Program?", "NPI", "PRESLSTNME", "Sign Off", "Dispensed or Reversed", "Revision/Edits Needed", "Confirmed:", "Date", "Error", "Notes", "Location", "Cont Phar Name", "NABPNUM", "Phar Address", "Phar City"

Code:
Sub MoveDataMont()


Rows("1:6").Delete
Application.CutCopyMode = False ' don't want an existing operation to interfere
Columns("C").Insert XlDirection.xlToRight
Columns("C").Value = Columns("T").Value
Columns("T").Delete


Application.CutCopyMode = False ' don't want an existing operation to interfere
Columns("A").Insert XlDirection.xlToRight
Columns("A").Value = Columns("B").Value


Application.CutCopyMode = False ' don't want an existing operation to interfere
Columns("B").Insert XlDirection.xlToRight
Columns("B").Value = Columns("C").Value


Cells.Replace What:="NDC 11", _
                            Replacement:="NDC", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=True
Cells.Replace What:="Payer Type", _
                            Replacement:="Payer", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=True


Columns("A").Replace What:=",*", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=True
Cells(1, 1).Value = "PATLSTNME"
                            
Columns("B").Replace What:="*,", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=True
                           Columns("C").Delete
Cells(1, 2).Value = "PATFRSNME"




Cells(1, 3).Value = "DOB"
Cells(1, 4).Value = "PT ID"
Cells(1, 5).Value = "PRESLSTNME"
Cells(1, 8).Value = "Cont Phar Name"
Cells(1, 9).Value = "Rx Number"
Cells(1, 10).Value = "Refill"
Cells(1, 12).Value = "Written Date"
Cells(1, 14).Value = "Date Submitted"
Cells(1, 22).Value = "Description"
Cells(1, 28).Value = "Qty"


                         


Columns("A").Insert XlDirection.xlToLeft
Cells(1, 1).Value = "Unqiue ID"


Columns("J:N").Insert XlDirection.xlToLeft
Columns("R:T").Insert XlDirection.xlToLeft
Columns("V").Insert XlDirection.xlToLeft
Columns("Y:AF").Insert XlDirection.xlToLeft
Columns("AH").Insert XlDirection.xlToLeft
Cells(1, 10).Value = "Cont Phar (Y/N)"
Cells(1, 11).Value = "ccc Location (Y/N)"
Cells(1, 12).Value = "In Scope?"
Cells(1, 13).Value = "EMR"
Cells(1, 14).Value = "Encounter Date"
Cells(1, 18).Value = "BIN"
Cells(1, 19).Value = "PCN"
Cells(1, 20).Value = "GROUPID"
Cells(1, 22).Value = "Program?"
Cells(1, 25).Value = "Sign Off"
Cells(1, 26).Value = "Dispensed or Reversed)"
Cells(1, 27).Value = "Revision/Edits Needed"
Cells(1, 28).Value = "Confirmed By:"
Cells(1, 29).Value = "Date"
Cells(1, 30).Value = "Error"
Cells(1, 31).Value = "Notes"
Cells(1, 32).Value = "Location"
Cells(1, 34).Value = "NABPNUM"
Columns("AK:AW").Insert XlDirection.xlToRight




Cells(1, 37).Value = "Phar City"
Cells(1, 38).Value = "Pro City"
Cells(1, 39).Value = "Pro City"
Cells(1, 40).Value = "PO Number"
Cells(1, 41).Value = "PO Repl Date"
Cells(1, 42).Value = "Inv Number"
Cells(1, 43).Value = "Location SRC"
Cells(1, 44).Value = "Location Address Final"
Cells(1, 45).Value = "Location Final"
Cells(1, 46).Value = "ADDRESS SORTING"
Cells(1, 47).Value = "Location Verified"
Cells(1, 48).Value = "prefilled"
Cells(1, 49).Value = "RXCLAIM"


Cells.Replace What:="Phar Intersection", _
                            Replacement:="Phar Address", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=True






With Application.ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
Application.ActiveWindow.FreezePanes = True
If Not ActiveSheet.AutoFilterMode Then
ActiveSheet.Range("A1").AutoFilter
End If


Dim v As Variant, x As Variant, findfield As Variant
Dim oCell As Range
Dim iNum As Long
v = Array("Unqiue ID", "PATFRSNME", "PATLSTNME", "DOB", "PT ID", "Rx Number", "Date Submitted", "Written Date", "Refill", "Cont Phar (Y/N)", "ccc Location (Y/N)", "In Scope? (Y/N)", "EMR", "Encounter Date", "NDC", "Description", "Qty", "BIN", "PCN", "GROUPID", "Payer", "Program?", "NPI", "PRESLSTNME", "Sign Off", "Dispensed or Reversed", "Revision/Edits Needed", "Confirmed:", "Date", "Error", "Notes", "Location", "Cont Phar Name", "NABPNUM", "Phar Address", "Phar City")
For x = LBound(v) To UBound(v)
findfield = v(x)
iNum = iNum + 1
Set oCell = ActiveSheet.Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not oCell.Column = iNum Then
Columns(oCell.Column).Cut
Columns(iNum).Insert Shift:=xlToRight
End If
Next x






End Sub
 

Some videos you may like

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

Ruddles

Well-known Member
Joined
Aug 24, 2010
Messages
5,786
How about sprinkling a few Debug.Print Format(Now(),"hh:mm:ss") statements at the top and the bottom, and between the main blocks of code, then check the Immediate window to see which bit of code is taking all the time?
 

Watch MrExcel Video

Forum statistics

Threads
1,127,645
Messages
5,626,065
Members
416,160
Latest member
SanbiVN

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