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]

Sub Datapoints2()
 Dim LastCol As Long, LastRow As Long, s1 As Worksheet, s2 As Worksheet
 Set s1 = Sheets("DATA")
 Set s2 = Sheets("Data Points")
 s1.Range("C2", s1.Cells(2, 3).End(xlToLeft)).Copy
 Sheets("Data Points").Range("D3").PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 ActiveWorkbook.Names.Add Name:="CTC", RefersToR1C1:="=DATA!C1"
 ActiveWorkbook.Names("CTC").Comment = ""
 ActiveWorkbook.Names.Add Name:="GRADE", RefersToR1C1:="=DATA!C2"
 ActiveWorkbook.Names("GRADE").Comment = ""
 s1.Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A3"), Unique:=True
 'Range("B4") = "Destination Region" - This is useless as code since the next line wipes it out.
 s2.Range("B4").FormulaArray = "=COUNT(IF(RC[-1]=GRADE,0))"
 s2.Range("B4").AutoFill Destination:=Range("B4:B" & Range("A4").End(xlDown).Row)
 'Range("C4") = "Destination Region" - see comment above
 s2.Range("C4").FormulaArray = "=LARGE(IF(RC[-2]=GRADE,CTC),INT((RC[-1]/2)+0.5))"
 s2.Range("C4").AutoFill Destination:=Range("C4:C" & Range("A4").End(xlDown).Row)
 'Range("D4") = "Destination Region" - see comment above
 s2.Range("D4").FormulaArray = "=INDEX(DATA!R3C[-1]:R858C[-1],MATCH(RC3,DATA!R3C1:R858C1,0))"
 s2.Range("D4").AutoFill Destination:=Range("D4:D" & Range("A4").End(xlDown).Row)
'The next three lines are redundant to the autofill.  The formulas are already in the range of cells.
 '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
 s2.Range("A3", Selection.End(xlToRight)).AutoFilter 'What is selected?
 s2.AutoFilter.Sort.SortFields.Clear
 s2.AutoFilter.Sort.SortFields.Add Key:= _
 s2.Range("C3"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
 xlSortNormal
    With s2.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 Selection.AutoFilter
 End Sub

 

[upendra2206]

Perfect !! The only change I had to make was from s1.Range("C2", s1.Cells(2, 3).End(xlToLeft)).Copy to s1.Range("C2", s1.Cells(2, 3).End(xlToRight)).Copy

And you have suggested not use these three lines but without which I was able to fill the data only till column D.

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

You also commented that the formula is already present in the remaining required cells. How?

and really appreciate you shortening down the code for me..

 

[JLGWhiz]

Perfect !! The only change I had to make was from s1.Range("C2", s1.Cells(2, 3).End(xlToLeft)).Copy to s1.Range("C2", s1.Cells(2, 3).End(xlToRight)).Copy

And you have suggested not use these three lines but without which I was able to fill the data only till column D.

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

You also commented that the formula is already present in the remaining required cells. How? and really appreciate you shortening down the code for me..

The autofill in the code segment prior to those three lines puts the formula in the cells down as far as there is data in column A. I assumed (maybe wrongly) that was the same bottom row as Column "C" since the Column C autofill used Column A as a reference for the last row also. But I only commented the lines out because I was not sure that you did not have some other purpose in mind. Not being able to see the worksheet, I could not really tell how far down column C has data compared to A.

 

[JLGWhiz]

s2.Range("A3", Selection.End(xlToRight)).AutoFilter 'What is selected?
Range("C2", Selection.End(xlToRight)).Copy

I am surprised if you are getting the results you expect with these two lines of code, since the Selection is what ever the active cell happens to be when you activate the macro. Of course, if it happens to be in column A, then you will most likely get expected results in this case because it would still be anchored to the left of you data. But if the active cell happened to be in Column Z, you would not get the results you expect. 'Selection' in code refers to the cell or range of cells that are selected (highlighted on the Excel sheet), and not the cell referred to in the Range statement in the code. I changed one of the statements to reflect where the anchor cell should be for the End() funtion. the End() function is the same as using the End and Arrow keys on the keyboard. It operates virtually the same way, except you have to explicitly tell it where to start from by specifying the anchor cells.
[Code}
Range("C2", Range("C2").End(xlToRight)) 'From C2 to the last cell before an blank cell.
Range("C2", Cells(2, Columns.Count).End(xlToLeft)) 'From C2 to the end of all data in row, including any blank cells
[/Code]

The two statements above will not necessarily yield the same results, but could. The first one will get data up to a blank cell.
The second one will get all the data in the row, ignoring any blank cells in between the first and last cells with data.

Just for info.

 

[upendra2206]

I have used to fill in the data in Column C & Column D with the reference to data in Column A. Now the formula in D4 will be applied to the the range D4:Z20 and hence I have used those three lines to fill in the data. Any other way of filling in the data?

 

[upendra2206]

I am not able to fill in the data with s1.Range("C2", s1.Cells(2, 3).End(xlToLeft)).Copy. This copies the the cells A2:C2 from the DATA Sheet and copies it to D3:F3 and when I use s1.Range("C2", s1.Cells(2, 3).End(xlToRight)).Copy it copies all the cell from C2: (last filled column)2 and pastes it to D3required)

 

[JLGWhiz]

I am not able to fill in the data with s1.Range("C2", s1.Cells(2, 3).End(xlToLeft)).Copy. This copies the the cells A2:C2 from the DATA Sheet and copies it to D3:F3 and when I use s1.Range("C2", s1.Cells(2, 3).End(xlToRight)).Copy it copies all the cell from C2: (last filled column)2 and pastes it to D3required)

This was an error on my part. Should have been"

s1.Range("C2", s1.Cells(2, Columns.Count).End(xlToLeft)).Copy

 

[JLGWhiz]

I have used to fill in the data in Column C & Column D with the reference to data in Column A. Now the formula in D4 will be applied to the the range D4:Z20 and hence I have used those three lines to fill in the data. Any other way of filling in the data?

That is why I left it, instead of deleting it. I see not that the LastCol variable could be further than column D. My oversight there. Just remove the apostrophe in front of the lines and it should do what you want.

 

[upendra2206]

Done !! Thanks alot..