Thread: help optimising VBA macro to move and sort data for use in validation lists

Hi,

I'm following a couple of steps to get to the end of what I need to do.
I've got a couple of sheets, the main one has a list of vehicle makes and models as well as other information.

1. I want to copy just the vehicle make and models to a new sheet "VehicleList"
2. Sort them on the new sheet by vehicle make and then by model, currently only sorting by make
3. Go through the list of vehicle makes and get out the unique ones to a new column
4. Compare the unique name in that new column with the entries in the original column and copy out the corresponding vehicle models to a new column under that vehicle make
5. Populate a name range "Lists" with only the names of the vehicle makes
6. Use the name range "Lists" in a data validation, Make_List, on sheet "Testing"
7. Based on the user choice from "Lists" setup a new data validation in name range Model_List with only the names of the vehicle models corresponding to the manufacturer.

The problem is that it is very slow, especially step 4. Step 5 is returning all the cell values in the first row of "VehicleList" sheet, which is not what I want, it should in effect only start capturing names from column 4 to the end. The rest seems to be working well. If anyone can help cleanup my code and give advice on making it more efficient as well as help to resolve step 6 I'd greatly appreciate it.

code
Sub MakeVehicleList()
' Define variables
Dim origvehsheet, targvehsheet As Worksheet
Dim selectRange, sortRange, filterRange As Range
Dim filteredRange, rFound, rCell As Range
Dim i, j, k As Integer

' Set values
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set origvehsheet = Worksheets("Rate00_MM_CODE_Vehicle_Groups")
Set targvehsheet = Worksheets("VehicleList")
Set selectRange = origvehsheet.Range("C1:D10000")
Set sortRange = targvehsheet.Range("A1:B10000")
Set filterRange = targvehsheet.Range("A2:A10000")
Set filteredRange = targvehsheet.Range("C2:C10000")

' Copy values to new sheet
selectRange.Copy Destination:=targvehsheet.Range("A1")
targvehsheet.Activate

' Sort and filter values
sortRange.SortSpecial xlStroke, , xlAscending, , , , , , xlYes, , True, xlSortColumns, xlSortNormal, xlSortNormal, xlSortNormal
filterRange.AdvancedFilter xlFilterCopy, , Range("C2:C10000"), True
filteredRange.Copy Destination:=targvehsheet.Range("C1")

' Create heading
Range("C1").Select
ActiveCell.Value = "UNIQUE"

' Sort models under manufacturer heading
For i = 2 To 200

' Set k = 1 to ensure model names start each time right beneath heading
k = 1
For j = 2 To 10000
If Cells(i, 3).Value = Cells(j, 1).Value Then
k = k + 1
Cells(1, 3).Offset(0, i - 1).Value = Cells(i, 3).Value
Cells(k, 3).Offset(0, i - 1).Value = Cells(j, 2).Value
End If

Next j
Next i

With targvehsheet
For Each rCell In .Range("D1").CurrentRegion.Rows(1).Cells
.Range(rCell.Cells(2, 1), rCell.End(xlDown)).Name = Replace(rCell.Cells(1, 1), " ", "_")
Next rCell
.Range("D1").CurrentRegion.Rows(1).Name = "Lists"
End With


Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
/code

Hi Apotomy, welcome to the forum.

Please take a moment to read the forum rules and then edit your thread to:

1. Create a thread title that is descriptive of your issue. "Help", "Formula Help", "VBA" etc. are not descriptive.

2. Add [code] ... [/code] tags around all VBA code in your post.

Other users will not respond to this thread until these changes have been made.