Help in Shortening the VBA code.

[upendra2206]

Hi, Below is my VBA code but since I am new to VBA, I think the code is pretty big and can be trimmed down without change of course of action. I am sorry but I cant share my data hence I have tried to explain what exactly I am trying to do in the code.
My course of action I mentioned Bold & Underline.

Public Sub Datapoints2()


Dim LastCol As Long, LastRow As Long, s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("DATA")
Set s2 = Sheets("Data Points")

(This will copy all the headings of my master data & paste in my “Data Points” sheet)
Sheets("DATA").Select
Range("C2", Selection.End(xlToRight)).Copy
Sheets("Data Points").Select
Range("D3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

(This will name my Column A to CTC and Col B to Grade)
ActiveWorkbook.Names.Add Name:="CTC", RefersToR1C1:="=DATA!C1"
ActiveWorkbook.Names("CTC").Comment = ""

ActiveWorkbook.Names.Add Name:="GRADE", RefersToR1C1:="=DATA!C2"
ActiveWorkbook.Names("GRADE").Comment = ""

(This will copy all the unique values from column B of DATA Sheets i.e. Unique grades and copy to Data Points sheet)
s1.Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A3"), Unique:=True

(This will auto fill the formula in Column B of DATA POINTS sheets with reference to column A)
Range("B4") = "Destination Region"
Range("B4").FormulaArray = "=COUNT(IF(RC[-1]=GRADE,0))"
Range("B4").AutoFill Destination:=Range("B4:B" & Range("A4").End(xlDown).row)


(This will auto fill the formula in Column C of DATA POINTS sheets with reference to column A)

Range("C4") = "Destination Region"
Range("C4").FormulaArray = "=LARGE(IF(RC[-2]=GRADE,CTC),INT((RC[-1]/2)+0.5))"
Range("C4").AutoFill Destination:=Range("C4:C" & Range("A4").End(xlDown).row)

(This will auto fill the formula in Column D of DATA POINTS sheets with reference to column A)

Range("D4") = "Destination Region"
Range("D4").FormulaArray = "=INDEX(DATA!R3C[-1]:R858C[-1],MATCH(RC3,DATA!R3C1:R858C1,0))"
Range("D4").AutoFill Destination:=Range("D4:D" & Range("A4").End(xlDown).row)

(Now my formula remains the same from cell D4 to the last populated column and row. Hence I will copy my formula from D4 to the last populated column and last populated row)

LastCol = Cells(3, Columns.COUNT).End(xlToLeft).Column
LastRow = Cells(Rows.COUNT, "C").End(xlUp).row
Range("D4", Cells(LastRow, LastCol)).FormulaR1C1 = Range("D4").FormulaR1C1

(This will sort the value as per the heading of the table i.e. C3 in descending and little bit of formating)

Range("A3", Selection.End(xlToRight)).AutoFilter

ActiveWorkbook.Worksheets("Data Points").AutoFilter.sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data Points").AutoFilter.sort.SortFields.Add Key:= _
Range("C3"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Data Points").AutoFilter.sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.AutoFilter

End Sub

 

[JLGWhiz]

Done !! Thanks alot..

You are welcome,
Regards, JLG