Related
I am using below code in one workbook as the following:
(1) Match a range on SheetA against a range on SheetB.
(2) If the data found on SheetB, then some values will be inserted on SheetB and Sheet Log.
(3) The matched data (rows) on SheetB will be copied to Sheet Result and Autofit.
(4) The matched data (rows) on SheetB will be cleared. (cut & paste is not applicable).
The count of values on the first range in SheetA is normally 7 or 8 and this macro was as fast as it takes 2 seconds to finish all that steps.
I tried to put 146 values on the first range, but the macro turned to be very slow and it took 35 seconds to finish.
Please, how to speed up and optimize this macro?
Note: there is no problem at all to change match code or copy, paste, autofit and clear code.
Link for the full macro and sheet on the first comment.
Sub Match_Copy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant
For Each Cell In WorkOrder
Match_A = Application.Match(Cell.value, Auto_Data, 0)
If Not IsError(Match_A) Then
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
If ws.name = "SheetB" Then 'Put Data of Close in Log Sheet
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3).value = _
Array(Application.UserName, Now, Cell)
End If
End If
Next Cell
'----------------------------- Copy, Paste, AutoFit and Clear Code
Dim StatusColumn As Range
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Copy
Dim DestRng As Range
Set DestRng = Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1)
DestRng.PasteSpecial xlPasteValues
DestRng.Rows.AutoFit
If DestRng.Rows.RowHeight < 45 Then DestRng.Rows.RowHeight = 45
End If
Next Cell
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Clear
End If
Next Cell
'-----------------------------
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End sub
Please, check the next adapted code. It uses arrays for faster iteration and for faster results return. Also, setting the row height for each cell consumes Excel resources. I commented some rows but no time now for everything. If something unclear, please do not hesitate to ask for clarifications:
Sub Run_Close()
Dim dStart As Double: dStart = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'------------------
Dim lastR As Long: lastR = Sheets("SheetA").Cells(Rows.Count, "A").End(xlUp).Row
Dim Auto_Data As Range: Set Auto_Data = Sheets("SheetA").Range("A2:A" & lastR)
Dim Count_Auto_Data As Long: Count_Auto_Data = WorksheetFunction.CountA(Auto_Data)
If Count_Auto_Data = 0 Then Exit Sub
With Auto_Data
.NumberFormat = "General"
.Value = .Value
End With
'------------------
Sheets("Result").AutoFilter.ShowAllData
Dim ws As Worksheet, arrWsFin, arrLog, k As Long
For Each ws In Sheets(Array("SheetB")) 'There are another 3 Sheets
ws.AutoFilter.ShowAllData
Dim LastRow As Long: LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Dim WorkOrder As Range: Set WorkOrder = ws.Range("A3:A" & LastRow)
Dim arrWO: arrWO = WorkOrder.Value2 'place the range in an array for faster iteration
ReDim arrWsFin(1 To LastRow, 1 To 3) 'redim array to keep the modifications in ws sheet
ReDim arrLog(1 To 3, 1 To LastRow): k = 1 'redim array to keep maximum modif of ws sheet
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant, i As Long
For i = 1 To UBound(arrWO)
Match_A = Application.Match(arrWO(i, 1), Auto_Data, 0)
If Not IsError(Match_A) Then
arrWsFin(i, 1) = "Close": arrWsFin(i, 2) = Now: arrWsFin(i, 3) = ws.name
If ws.name = "SheetB" Then 'Put Data of Close in the array for further return at once
arrLog(1, k) = Application.UserName: arrLog(2, k) = Now: arrLog(3, k) = arrWO(i, 1): k = k + 1
End If
End If
Next i
ws.Range("G2").Resize(UBound(arrWsFin), UBound(arrWsFin, 2)).Value = arrWsFin
If k > 1 Then
ReDim Preserve arrLog(1 To 3, 1 To k - 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(arrLog, 2), UBound(arrLog)).Value = Application.Transpose(arrLog)
End If
'----------------------------- Copy, Paste and AutoFit, Code
Dim StatusColumn As Range, totRng As Range, lastCol As Long, arrSt, arrResult, arrRow, j As Long
lastR = ws.Cells(Rows.Count, "G").End(xlUp).Row
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
arrSt = StatusColumn.Value2 'place the range in an array for faster iteration
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set totRng = ws.Range("A2", ws.Cells(lastR, lastCol)) 'total range to extract the row slice
Dim rngClearCont As Range
ReDim arrResult(1 To lastCol, 1 To lastR): k = 1
For i = 1 To UBound(arrSt)
If arrSt(i, 1) = "Close" Then
arrRow = totRng.Rows(i).Value
'load arrResult array:
For j = 1 To lastCol
arrResult(j, k) = arrRow(1, j)
Next
k = k + 1
If rngClearCont Is Nothing Then
Set rngClearCont = StatusColumn.Cells(i) 'set the range necessary to clear rows at the end
Else
Set rngClearCont = Union(rngClearCont, StatusColumn.Cells(i))
End If
End If
Next i
If k > 1 Then
ReDim Preserve arrResult(1 To lastCol, 1 To k - 1)
With Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrResult, 2), _
UBound(arrResult))
.Value = Application.Transpose(arrResult)
.Rows.RowHeight = 45
End With
rngClearCont.EntireRow.ClearContents
End If
'-----------------------------
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
It should take less than a second...
The root of your issue is that you are making many edits to the worksheet. One of the first ways to speed up VBA code is to reduce the number of times you write data to the sheet.
Rather than writing your data to the sheet every time in a For Each loop, add all of your data to an Array and then write that entire Array to the sheet(s) at once. This way, you don't have to write multiple times for every For Each loop, but only once.
I cannot guarantee that this is the only reason your code is "sub-optimal" but it's a good place to start to improve performance times.
While writing to the sheet does take time, the main problem here is the copy/paste part.
If you, after the row
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
Put something like:
Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 9).value = Array(Cell, , , , , , "Close", Now, ws.name)
And then remove the copy/paste part completely, you should be able to run it almost instantly.
I have an Excel Workbook with hundreds of columns to be rearranged. Having tried different approaches to rearrange those columns I have developed my own solution, because it's faster than what I have found here and elsewhere:
How to rearrange the excel columns by the columns header name
https://code.adonline.id.au/rearrange-columns-excel-vba/
My code:
What I basically do is searching the header row for a certain string and copy that column to a temp/helper sheet, when done I search for the next term and so on until all categories are searched. Afterwards I copy the chunk back to the main sheet in the correct order.
edit: it is of vital importance to keep the formatting of each column, so putting everything in an array does not work, because the formatting information will be gone.
Sub cutColumnsToTempAndMoveBackSorted()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call declareVariables
iCountCompanies = lngLastCol - iColStart + 1
' Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
' Remember time when macro starts
StartTime = Timer
iStartColTemp = 0
wsTempCompanies.UsedRange.Delete
' First copy all columns with "ABC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "ABC" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "DDD"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "DDD" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "CCC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "CCC" Or ws.Cells(iRowCategory, i) = "" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "EEE"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
Dim iLastColTemp As Integer: iLastColTemp = iStartColTemp
iStartColTemp = 1
ws.Range(Col_Letter(iColStart) & ":" & Col_Letter(lngLastCol)).Delete 'Col_Letter function gives back the column ist characters instead of column ID
' Move back to Main Sheet
wsTempCompanies.Range(Col_Letter(iStartColTemp) & ":" & Col_Letter(iLastColTemp)).Copy
ws.Range(Col_Letter(iColStart + 1) & ":" & Col_Letter(lngLastCol + 1)).Insert
ws.Columns(iColStart).Delete
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
Debug.Print "Time: " & SecondsElapsed & " Sekunden."
ende:
Application.ScreenUpdating = True
Call activateApplication ' All kinds of screenupdates, such as enableevents, calculations, ...
End Sub
I am still not happy with my solution as it takes just too much time when there are more than 50 columns. Sometimes I have over 300.
Any suggestion to boost the performance?
The below might be of some help, if it is not too much effort.
Sample Dataset in one sheet (let's call this the Main sheet) with,
(Row 2) Sample Header row (includes the lookup keywords - ABC, DDD, CCC, EEE)
(Row 1) A Temp Row (formulated to show Header Order numbers)
References sheet which lists the lookup keywords in required left-to-right sort order
Back in the Main sheet, we'd like to generate the sequence numbers in Row 1.
As highlighted in the 1st image, it can be done with the below MATCH formula in the cell A1,
=MATCH(TRUE,ISNUMBER(SEARCH(References!$A$2:$A$5,A2)),0)
This is required as an array formula and hence should be executed by hitting Ctrl+Shift+Enter
Now copy the cell A1 across columns (in Row 1) through the last column
Row 1 will now contain sequence numbers 1..n, where n is the numbers of rows found in the References sheet. It may also contain #N/A error value returned by the MATCH formula if no match is found from the 'References' sheet
Now, apply sort (Sort Option: Left to Right) and Sort By Row 1.
The columns should now be sorted as per requirement and with formatting intact.
Result (Sorted)
Please note that a column header not matching any keywords has been moved to the end.
Once you find everything in place, now you can go ahead and delete the (Row 1) temp row in the Main sheet
P.S: While I haven't computed the performance of this approach on a large dataset, I'm sure it will be fairly quick.
Please test the next code, please. Most of the credit must go to #Karthick Ganesan for his idea. The code only puts his idea in VBA:
Sub reorderColumnsByRanking()
Dim sh As Worksheet, arrOrd As Variant, lastCol As Long, i As Long
Dim El As Variant, boolFound As Boolean, isF As Long
Set sh = ActiveSheet 'use here your necessary sheet
lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
arrOrd = Split("ABC|1,DDD|2,CCC|3,EEE|4", ",") 'load criteria and their rank
'insert a helping row____________________
sh.Range("A1").EntireRow.Insert xlAbove
'________________________________________
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Rank the columns_______________________________________________________________
For i = 1 To lastCol
For Each El In arrOrd
If IsFound(sh.Cells(2, i), CStr(Split(El, "|")(0))) Then
sh.Cells(1, i).Value = Split(El, "|")(1): boolFound = True: Exit For
End If
Next
If Not boolFound Then sh.Cells(1, i).Value = 16000
boolFound = False
Next i
'_______________________________________________________________________________
'Sort LeftToRight_____________________________________________________________
sh.Sort.SortFields.Add2 key:=sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
.SetRange sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
'____________________________________________________________________________
'Delete helping first row____
sh.Rows(1).Delete xlDown
'____________________________
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
Private Function IsFound(rng As Range, strS As String) As Boolean
Dim fC As Range
Set fC = rng.Find(strS)
If Not fC Is Nothing Then
IsFound = True
Else
IsFound = False
End If
End Function
Here's my take on the solution. It's pretty similar to the one in your first link by #BruceWayne except this will go straight to the correct column rather than checking each one.
At the moment the code looks for partial matches - so "ABCDEF" would be found for both "ABC" and "DEF". Change xlPart to xlWhole in the FIND command to have it match against exact headings.
Sub Test()
Dim CorrectOrder() As Variant
Dim OrderItem As Variant
Dim FoundItem As Range
Dim FirstAddress As String
Dim NewOrder As Collection
Dim LastColumn As Range
Dim NewPosition As Long
Dim tmpsht As Worksheet
CorrectOrder = Array("ABC", "DEF", "GHI", "JKL")
With ThisWorkbook.Worksheets("Sheet1")
Set LastColumn = .Cells(2, .Columns.Count).End(xlToLeft) 'Return a reference to last column on row 2.
Set NewOrder = New Collection
With .Range(.Cells(2, 1), LastColumn) 'Refer to the range A2:LastColumn.
'Search for each occurrence of each value and add the column number to a collection in the order found.
For Each OrderItem In CorrectOrder
Set FoundItem = .Find(What:=OrderItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not FoundItem Is Nothing Then
FirstAddress = FoundItem.Address
Do
NewOrder.Add FoundItem.Column
Set FoundItem = .FindNext(FoundItem)
Loop While FoundItem.Address <> FirstAddress
End If
Next OrderItem
End With
End With
'Providing some columns have been found then move them in order to a temporary sheet.
If NewOrder.Count > 1 Then
NewPosition = 2
Set tmpsht = ThisWorkbook.Worksheets.Add
For Each OrderItem In NewOrder
ThisWorkbook.Worksheets("Sheet1").Columns(OrderItem).Cut _
tmpsht.Columns(NewPosition)
NewPosition = NewPosition + 1
Next OrderItem
'Copy the reordered columns back to the original sheet.
tmpsht.Columns(2).Resize(, NewOrder.Count).Cut _
ThisWorkbook.Worksheets("Sheet1").Columns(2)
'Delete the temp sheet.
Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True
End If
End Sub
You can use Cut which is significantly faster (on PC it is around 20-30 times faster than Copy/Insert approach. Cut also preserves formatting.
Here, is an example how it can be implemented into your code:
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Cut wsTempCompanies.Columns(iStartColTemp)
End If
Next i
If for some reason, you are not allowed to cut elements from ws, then it is probably good idea to create temporary copy of that working to work on.
[
I am working on two sheets
Sheets("UPDATER") = where input data is placed (more than 700 rows) and where data needs to be copied
Sheets("Historical_vol) = where i have kept the formulas (C9:N9) and input the records from updater sheet in cell A9 of historical_vol sheet.
The aim is to get the values of each of Underlyings pasted in sheets("updater").columns("AB") but the values get calculated from sheets("Historical_vol").column(C9:F9) then paste these values in sheet("updater")on each row starts from cell AD4.
Sub historical_vol()
Dim i As Long
Dim a As Worksheet
Dim b As Worksheet
lr = Worksheets("UPDATER").Cells(Rows.count, "AB").End(xlUp).Row
Set a = Worksheets("UPDATER")
Set b = Worksheets("Historical_vol")
For i = 4 To lr
b.Range("A9").value = a.Range("AB4" & i).value
'b.Range("C9":F9").Calculate
Application.Wait (Now + TimeValue("00:00:02"))
b.Range("C9:F9").Copy
NextRow = Cells(Rows.count, "AD").End(xlUp).Row + 1
Cells(NextRow, "AD").Select
ActiveSheet.Paste
Next i
End Sub
At first I notice the line b.Range("A9").value = a.Range("AB4" & i).value should be b.Range("A9").value = a.Range("AB" & i).value
As I see you are using Application.Wait, I assume it is for the calculation. So, I suggest using xlCalculationManual calculation and resetting it to auto once done as below.
Sub historical_vol()
Application.ScreenUpdating = True
'This will help to watch the status bar update
Application.Calculation = xlCalculationManual
Dim wb As Workbook, uPd As Worksheet, hV As Worksheet
Dim lr As Long, cl As Range
Set wb = ThisWorkbook
Set uPd = wb.Sheets("UPDATER")
Set hV = wb.Sheets("Historical_vol")
lr = uPd.Cells(Rows.Count, "AB").End(xlUp).Row
i = 0
For Each cl In uPd.Range("AB4:AB" & lr)
hV.Range("A9").Value = cl.Value
hV.Calculate
cl.Offset(0, 2).Resize(1, 4).Value = hV.Range("C9:F9").Value
i = i + 1
Application.StatusBar = i '& " / " & lr - 3
'View on status bar number of records completed out of total records (lr-3)
Next
Application.Calculation = xlCalculationAutomatic
End Sub
I have an Excel file with around 100,000 records. I have 6+ columns, the first five of which are:
Required Format:
So far I have :
Sub Main()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
sameRows = True
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 4
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 4), Cells(i + 1, 4)).merge
End If
sameRows = True
Next i
End Sub
I am able to get below by running the macro by changing value in Range from 4 to 1/2/3/4 and running macro four times.
Please help me get the data in required format. I still need to merge the empty fields with the previous non empty field.
Pratik, listen carefully to Jeeped. Working with large data in Excel isn't ideal, and working with raw data in merged cells is staring into the abyss - it's a dark, dark place where Range referencing and things like Offset functions will show you a dimension of despair you never knew existed.
If you have this data in another format, say XML, that you've imported into Excel then use VBA to read the data, query it, etc. in its original format. If it exists in a database, then, again, use VBA to access that database and manipulate the recordsets as you wish. If this is your only source of data, then why not write it into an XML document or into VBA's own data storage options (like Collection or arrays).
If you have to use Excel then don't confuse raw data with data display. Yes, the merged cells might be easier to read for the human eye, but I'd just pose the question: is that your primary objective in conducting the merge?
If you must take that leap into the abyss - and you can see that at least two of us would advise against - then at least speed things up by reading from an array and merging rows at a time:
Sub OpenDoorsToHades()
Dim dataSheet As Worksheet
Dim v As Variant
Dim mergeCells As Range
Dim mergeAreas As Range
Dim i As Long
Dim blankStart As Long
Dim blankEnd As Long
Dim doMerge As Boolean
Dim c As Integer
Set dataSheet = ThisWorkbook.Worksheets("data") 'rename to your sheet
'Read values into array of variants
With dataSheet
v = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
'Check for blanks
For i = 1 To UBound(v, 1)
If IsEmpty(v(i, 1)) Then
If Not doMerge Then
blankStart = i - 1
doMerge = True
End If
Else
If doMerge Then
blankEnd = i - 1
For c = 1 To 4
With dataSheet
Set mergeCells = .Range( _
.Cells(blankStart, c), _
.Cells(blankEnd, c))
If mergeAreas Is Nothing Then
Set mergeAreas = mergeCells
Else
Set mergeAreas = .Range(mergeAreas.Address & _
"," & mergeCells.Address)
End If
End With
Next
mergeAreas.Merge
Set mergeAreas = Nothing
doMerge = False
End If
End If
Next
'Format the sheet
dataSheet.Cells.VerticalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
How about just populating the empty cells with the values above, so the values on the far right are associated with the same values that would've been in the merged cell. For example, if 19 is in cell A2, you can recreate the table starting in G2 with =IF(A2<>"",A2,G1), and this way all empty cells will be populated with the value above, pairing the values at the far right with the exact same values.
I tackled the same problem myself this week. Ambie's solution seemed overly complex, so I wrote something pretty simple to merge rows:
Sub MergeRows()
Sheets("Sheet1").Select
Dim lngStart As Long
Dim lngEnd As Long
Dim myRow As Long
'Disable popup alerts that appear when merging rows like this
Application.DisplayAlerts = False
lngStart = 2
lngEnd = 2
For myRow = 2 To Range("A" & Rows.Count).End(xlUp).Row 'last row
If Range("A" & (myRow + 1)).value = "" Then
'include row below in next merge
lngEnd = myRow + 1
Else
'merge if 2+ rows are included
If lngEnd - lngStart > 0 Then
Range("A" & lngStart & ":A" & lngEnd).Merge
Range("B" & lngStart & ":B" & lngEnd).Merge
Range("C" & lngStart & ":C" & lngEnd).Merge
Range("D" & lngStart & ":D" & lngEnd).Merge
End If
'reset included rows
lngStart = myRow + 1
lngEnd = myRow + 1
End If
Next myRow
Application.DisplayAlerts = True
End Sub
I am new to VBA and I have been using the great help within this site, to create a macro to take a list of numbers from one sheet (Sheet 14), remove the duplicates and paste within another sheet (Sheet 2).
I am hoping to take this further by rather than pasting the cells one after another I am looking to have the list pasted in alternate rows i.e D10, D12, D14 etc.
I have tried various methods from within this site, however to no avail. I have used different types of "Step" functions but I am struggling to incorporate this within the below coding.
Any help is much appreciated!
Below is what I have at the moment:
Sub RUN()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Sheet14.Activate
lastRow = Sheet14.Cells(Rows.Count, "F").End(xlUp).Row
On Error Resume Next
For i = 3 To lastRow
If Len(Cells(i, "F")) <> 0 Then
dictionary.Add Cells(i, "F").Value, 1
End If
Next
Sheet2.Range("d10").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
MsgBox dictionary.Count & " RUN TEMPLATES."
End Sub
Here's one approach (BTW, I wouldn't call a macro RUN):
Sub ListUniques()
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Dim vKeys
Application.ScreenUpdating = False
Set dictionary = CreateObject("scripting.dictionary")
With Sheet14
lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 3 To lastRow
If Len(.Cells(i, "F")) <> 0 Then
dictionary(.Cells(i, "F").Value) = 1
End If
Next
End With
vKeys = dictionary.keys
For i = LBound(vKeys) To UBound(vKeys)
Sheet2.Range("d10").Offset(2 * i).Value = vKeys(i)
Next i
Application.ScreenUpdating = True
MsgBox dictionary.Count & " RUN TEMPLATES."
End Sub