I want to find all the cells in Column L with a particular value and return the values in Column D of the same row as those cells found.
So far, I am only able to return one result, which would be the top most result in my list, but I want to find all the rest as well, which I don't know the code to use.
Just to further explain: Value in cell D11 is the value I want to find in Column L of sheet "Master List". Supposedly I find the value in cells L13, L15 and L20, I want to return the value in cell D13, D15 and D20 into cells "C37:C39" of ws. Note: no. of cells that have the value may vary so the values returned will just appear from C37 downwards (something like automatic multiple selection, copy and paste)
Here's a little something to start the ball rolling:
Sub FindRelatedProducts()
Dim cell As Excel.Range
Dim D11Value As Variant
Dim D11Row As Variant
Dim ws As Worksheet: Set ws = Sheets("RShip")
Set cell = ws.Range("D11")
D11Value = cell.Value
With Sheets("Master List")
D11Row = Application.Match(D11Value, .Range("L:L"), 0)
If Not IsError(D11Row) Then
ws.Range("C37") = .Range("D" & D11Row).Value
End If
End With
End Sub
Here's an example using range variables.
You'll want to define a range for the input data range and a range for the output data. Then in the VBA you will want to change the wrk, inRng and outRng variables to be the named ranges you defined and change the column indexes in the for and if blocks to match the column index of the data you are looking for.
Option Explicit
Option Base 1
Sub FindValues()
Dim wrk As Worksheet
Dim inRng As Range
Dim outRng As Range
Dim cntr As Long
Dim outCntr As Long
Dim findVal As Double
Set wrk = Worksheets("Data")
Set inRng = wrk.Range("LookupRange")
Set outRng = wrk.Range("OutputRange")
' Clear the output range in case you have fewer values on this run than on the previous one
outRng.ClearContents
' Set the value you are looking for
findVal = 1
' Iterate through the rows in the input range. If you find the result you want then write it to the output range
For cntr = 1 To inRng.Rows.Count
If inRng(cntr, 1) = findVal Then ' Assumes the value you are finding is in column 1 of the input range
outRng(outCntr, 1) = inRng(cntr, 2) ' Assumes the values you are exporting is in column 2 of the input range
outCntr = outCntr + 1
End If
Next cntr
End Sub
Related
I'm trying to fill blank cells in a certain region with 0. The reagion should be defined in the current workbook but in sheet2 (not the current sheet). Also the place where it is supposed to fill is between columns
BU:CQ in the current region (not all 100 000 000 lines). Just the number of lines that define the table between columns BU and CQ. I know the problem lies in defining the region... See the code below.
What is missing?
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
InputValue = "0"
For Each cell In ThisWorkbook.Sheets("Sheet2").Range(BU).CurrentRegion
'.Cells(Rows.Count, 2).End(xlUp).Row
If IsEmpty(cell) Then
cell.Value = InputValue
End If
Next
End Sub
I've this code that i'm positive that works! But i don't wnat selection! I want somthing that specifies the sheet and a fixed range.
Now my idea is to replace "selection" with the desired range. - In this case in particular the range should be 1 - between BU:CQ; 2 - starting at row 2; 3 - working the way down until last row (not empty = end of the table that goes from column A to DE)
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = "0"
End If
Next
End Sub'
PS: And I also need to specify the sheet, since the button that will execute the code will be in the same workbook but not in the same sheet.
Use SpecialsCells:
On Error Resume Next 'for the case the range would be all filled
With ws
Intersect(.UsedRange, .Range("BU:CQ")).SpecialCells(xlCellTypeBlanks).Value = 0
End With
On Error GoTo 0
MUCH faster than looping !
Try using cells() references, such as:
For i = cells(1,"BU").Column to cells(1,"CQ").Column
cells(1,i).value = "Moo"
Next i
In your current code you list Range(BU) which is not appropriate syntax. Note that Range() can be used for named ranges, e.g., Range("TheseCells"), but the actual cell references are written as Range("A1"), etc. For Cell(), you would use Cells(row,col).
Edit1
With if statement, with second loop:
Dim i as long, j as long, lr as long
lr = cells(rows.count,1).end(xlup).row
For i = 2 to lr 'assumes headers in row 1
For j = cells(1,"BU").Column to cells(1,"CQ").Column
If cells(i,j).value = "" then cells(i,j).value = "Moo"
Next j
Next i
First off, you should reference the worksheet you're working with using:
Set ws = Excel.Application.ThisWorkbook.Worksheets(MyWorksheetName)
Otherwise VBA is going to choose the worksheet for you, and it may or may not be the worksheet you want to work with.
And then use it to specify ranges on specific worksheets such as ws.Range or ws.Cells. This is a much better method for specifying which worksheet you're working on.
Now for your question:
I would reference the range using the following syntax:
Dim MyRange As Range
Set MyRange = ws.Range("BU:CQ")
I would iterate through the range like so:
Edit: I tested this and it works. Obviously you will want to change the range and worksheet reference; I assume you're competent enough to do this yourself. I didn't make a variable for my worksheet because another way to reference a worksheet is to use the worksheet's (Name) property in the property window, which you can set to whatever you want; this is a free, global variable.
Where I defined testWS in the properties window:
Public Sub test()
Dim MyRange As Range
Dim tblHeight As Long
Dim tblLength As Long
Dim offsetLen As Long
Dim i As Long
Dim j As Long
With testWS
'set this this to your "BU:CQ" range
Set MyRange = .Range("P:W")
'set this to "A:BU" to get the offset from A to BU
offsetLen = .Range("A:P").Columns.Count - 1
'set this to your "A" range
tblHeight = .Range("P" & .Rows.Count).End(xlUp).Row
tblLength = MyRange.Columns.Count
End With
'iterate through the number of rows
For i = 1 To tblHeight
'iterate through the number of columns
For j = 1 To tblLength
If IsEmpty(testWS.Cells(i, offsetLen + j).Value) Then
testWS.Cells(i, offsetLen + j).Value = 0
End If
Next
Next
End Sub
Before:
After (I stopped it early, so it didn't go through all the rows in the file):
If there's a better way to do this, then let me know.
so recently I have been looking into using defined ranges to copy data instead of selecting, copying and pasting cells. This way I hope to optimise the performance and the runtime of my code.
Unfortunately I have come to face a problem I wasn't able to solve on my own.
When defining a range I want to rearrange the columns in a different order.
For example:
Set my_range = Sheets("Sheet1").Range("A2:E2,G2:H2,J2:K2,M2")
Works well, as the columns I fill into the range are behind each other in the sheet. But now I have this:
Set yo_range = Sheets("Sheet2").Range("D2,AV2,L2,H2,Q2,AE2,AG2")
If I fill these ranges into a new sheet the yo_range will fill the columns I put into it but not in the order I written down. It will put it down in the order according to the original one. In this example yo_range would put the data in this order into the new sheet:
D2 | H2 | L2 | Q2 | AE2 | AG2 | AV2
How can I fix this? I want the order to be another one than the original one.
Also - as you can see my_range has more columns than yo_range. How can I let yo_range be filled into the new sheet but at certain points leave columns out? For example:
my_range(A2:E2) goes into A2:E2 in the new sheet
yo_range(D2,AV2) goes into A:B in the new sheet, then leave C out and then paste yo_range(L2,H2) into D:E in the new sheet
I hope that I was able to explain my problem well and that there is somebody able and willing to help me. Any help is appreciated.
Edit:
Here's the code that puts the values from the ranges into the new sheet
Do
If Application.WorksheetFunction.CountA(my_range) > 0 Then
my_range.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
Set my_range = my_range.Offset(1, 0)
Else
Exit Do
End If
Loop
Do
If Application.WorksheetFunction.CountA(yo_range) > 0 Then
yo_range.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
Set yo_range = yo_range.Offset(1, 0)
Else
Exit Do
End If
Loop
We can see that the Copy method will re-arrange the data left-to-right. Try this:
Option Explicit
Public Sub CheckClipboard()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim objData As Object
Dim varContents As Variant
' test data b,c,d,e,f,g in Sheet1!B1:G1
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("B1:G1").Value = Array("b", "c", "d", "e", "f", "g")
Set rngToCopy = ws.Range("E1:F1,G1,B1:C1") '<-- note not left-to-right order
rngToCopy.Copy '<-- copy
' this is a late bound MSForms.DataObject
Set objData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
' copy current cell formula to clipboard
objData.GetFromClipboard
varContents = objData.GetText
Debug.Print varContents '<-- re-arranged left-to-right
' cancel copy
Application.CutCopyMode = False
End Sub
I get this in the immediate window:
b c d e f g
So, using Copy is not going to work for what you want to do.
In order to 'paste' the data in the order that you set it in the Range, you need to iterate each Area of the Range and then each cell (i.e. Range) in each Area. See the test code below which replicates your issue and presents a solution:
Option Explicit
Sub MixColumns()
Dim ws As Worksheet
Dim rngIn As Range
Dim rngOut As Range
Dim lng As Long
Dim rngArea As Range
Dim rngCell As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
' example 1
Set rngIn = ws.Range("B1:C1,E1:F1,G1") '<-- 5 cells, non-contiguous, forward order
Set rngOut = ws.Range("B2:F2") '<-- 5 contiguous cells
rngIn.Copy rngOut '<-- works
' example 2 - OP problem
Set rngIn = ws.Range("E1:F1,G1,B1:C1") '<-- 5 cells, non-contiguous, odd order
Set rngOut = ws.Range("B3:F3") '<-- 5 contiguous cells
rngIn.Copy rngOut '<-- should be e,f,g,b,c but gets b,c,e,f,g
' example 3 - solution for OP problem
Set rngIn = ws.Range("E1:F1,G1,B1:C1") '<-- 5 cells, non-contiguous, odd order
Set rngOut = ws.Range("B4:F4") '<-- 5 contiguous cells
lng = 1 '<-- rngOut cell counter
' iterate areas
For Each rngArea In rngIn.Areas
' iterate cells in area
For Each rngCell In rngArea.Cells
rngOut.Cells(1, lng).Value = rngCell.Value '<-- copy single value
lng = lng + 1 '<-- increment rngOut counter
Next rngCell
Next rngArea '<-- results in e,f,g,b,c
End Sub
Give this output:
I have a somewhat simple macro that I have made but I am rusty as I have not coded in a few years. As simply as I can put it, I Have two different Workbooks. If the workbook I have open has a certain value (or no value), I want it to fill the other workbook("Test Template") with either "proposal or pre-proposal."
That has all been easy for me. But since the worksheet adds rows as we input data, I need it to fill those values in the next available row.
I will attach code but don't worry about the proposal stuff, I just need the range changed from a specific cell into the next available cell in the column. (if d28 is full, put in d29).
Public Sub foo()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = ActiveWorkbook
Set y = Workbooks.Open("C:\Users\hmaggio\Desktop\Test Template.xlsx")
'copy Names from x(active):
x.Sheets("Sheet1").Range("C4").Copy
'paste to y worksheet(template):
y.Sheets("Sheet1").Range("B28").PasteSpecial
If x.Sheets("Sheet1").Range("C15") = "" Then
y.Sheets("Sheet1").Range("D28").Value = "proposal"
Else
y.Sheets("Sheet1").Range("D28").Value = "preproposal"
End If
First, you need a variable where you'll store the last used row number:
dim lngRows as long
lngRows = Cells(Rows.Count, "D").End(xlUp).Row
Then replace your lines of code where you have .Range("B28") with either .Cells(lngRows+1,2) or .Range("B"&lngRows)
The object Range offers a method called End that returns the last range on a certain direction.
Range("A1").End(xlDown) '<-- returns the last non-empty range going down from cell A1
Range("A1").End(xlUp) '<-- same, but going up
Range("A1").End(xlToRight) '<-- same, but going right
Range("A2").End(xlToLeft) '<-- same, but going left
In your case, hence, you can detect and use the last row of column B like this:
nextRow = y.Sheets("Sheet1").Range("B3").End(xlDown).Row + 1
More details:
The first Range of your column B is the header Range("B3")
You get the last filled range going down with .End(xlDown)
Specifically, you get the Row of that range
You add + 1 (cause you want the next available row
You store the row in the variable nextRow
... that you can then use like this:
y.Sheets("Sheet1").Range("B" & nextRow ).PasteSpecial
Try this
Public Sub foo()
Dim x As Workbook
Dim y As Workbook
Dim fromWs As Worksheet
Dim toWs As Worksheet
Dim Target As Range
'## Open both workbooks first:
Set x = ActiveWorkbook
Set y = Workbooks.Open("C:\Users\hmaggio\Desktop\Test Template.xlsx")
Set fromWs = x.Sheets("Sheet1")
Set toWs = y.Sheets("Sheet1")
With fromWs
Set Target = toWs.Range("b" & Rows.Count).End(xlUp)(2) '<~~next row Column B cell
Target = .Range("c4") 'Column B
If .Range("c15") = "" Then
Target.Offset(, 2) = "proposal" 'Column D
Else
Target.Offset(, 2) = "preproposal"
End If
End With
End Sub
I'm trying to write a code that either deletes or keeps rows by a specific word input by the end-user.
I've created two button actions:
Sub Button1_Click()
Dim cell As Range
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
For Each cell In Selection
cell.EntireRow.Hidden = (InStr(1, cell, word1, 1) = 0) 'keep by a word input by the user
Next
End Sub
Sub Button2_Click()
Dim cell As Range
word2 = InputBox("Enter a word by which you want to delete rows", "Enter")
For Each cell In Selection
cell.EntireRow.Hidden = (InStr(1, cell, word2, 1) = 1) 'delete by a word input by the user
Next
End Sub
However, these buttons don't work quite the way I would like them to do.
Problems:
1) I have to specifically select the cells in the column of the text to be searched; if I select the whole block of data,everything will be deleted.
2) Actually, the program would be handier, if it did its magic from the cell J22 onwards (to the right and downwards) until the end of the data is reached, without the need to select anything. What is the best way to do this?
3) If I use these buttons several times sequentially, the rows that I've already deleted keep popping up again. How to make the delete "permanent" each time I use one of these buttons? By changing Hidden to Delete I start to get run-time errors.
When you attempt to delete permanently the macro deletes a row, shifts all of the other rows up one to accomodate and this disrupts the flow of your 'For Each...Next'.
There are a couple of ways around this either way it very much changes the shape of your code.
One of them is to add the rows you wish to delete to a union during the loop and then delete the union outside of the loop (example A below). In any case it sounds like you want to specify the range you want this code to work on so I've incorporated that into each example.
Example A
Sub Button1_Click()
Dim endR As Integer, endC As Integer 'depending on size of sheet may need to change to Long
Dim cell As Range, rng As Range, U As Range
Dim ws As Worksheet
Set ws = Sheets(2) ' change accordingly
endR = ws.UsedRange.Rows.Count
endC = ws.UsedRange.Columns.Count
Set rng = Range(ws.Cells(22, 10), ws.Cells(endR, endC)) ' from cell J22 to last used row of the last used column on the right
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
For Each cell In rng
If InStr(1, cell, word1, 1) = 0 Then
If U Is Nothing Then ' for the first time the code finds a match
Set U = cell.EntireRow ' add row to be deleted to U variable
Else
Set U = Union(U, cell.EntireRow) ' for any subsequent matches, add row to be deleted to Union
End If
End If
Next
U.Delete
End Sub
The other way to do it would be to define the exact ranges you want to work with at the start of your code and then loop backwards through that range using loop control variables instead of for each, that way when you delete a row, the shift up doesn't impact the loop.
Sub Button2_Click()
Dim r As Integer, c As Integer
Dim endR As Integer, endC As Integer
Dim cell As Range, rng As Range
Dim ws As Worksheet
Set ws = Sheets(2) ' change accordingly
endC = ws.UsedRange.Columns.Count
word2 = InputBox("Enter a word by which you want to delete rows", "Enter")
For c = 10 To endC ' start from J and move to the right
endR = ws.UsedRange.Rows.Count ' after each column has been dealt with, re-evaluate the total rows in the worksheet
For r = endR To 22 Step -1 ' start from the last row and work up
If InStr(1, ws.Cells(r, c), word2, 1) = 1 Then
ws.Cells(r, c).EntireRow.Delete
End If
Next r
Next c
End Sub
With your current code, if you select the whole block of data, it checks each cell in that selection individually and acts accordingly. If you have a range selected like A1:J1,000, it will hide every row unless each cell in every row of the selection contains the input word.
Depending on what you exactly want, you could try something Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.count, 10).End(xlUp).Row this returns the rownumber of the last cell in column 10(J), more examples of this in the code below
This is caused by the for loop and the deletion of rows, say For i = 1 To 100 you check cells A1 to A100, if you then delete a row during that loop, the loop will still continue to 100 and not end at 99, the end of the loop is set before the loop starts and does not change during the loop. More information on that and it's solutions here.
General
Avoid the .Select/.Activate methods and .Selection property, it is a source of many bugs.
Declare all your variables, use Option Explicit to enforce this.
Here is the refactored code with annotations.
Option Explicit
Sub Button1_Click()
'Keep rows based on input
'Declaration of variables
Dim i As Long
Dim strFilterWord As String
Dim rngCell As Range
Dim rngToDelete As Range, rngRow As Range
Dim arrRow() As Variant, arrTmp() As Variant
'Setting the filter word
strFilterWord = InputBox("Enter a word by which you want to keep rows", "Enter")
With ThisWorkbook.Worksheets("Sheet1") 'Replace "Sheet1" with the actual name of your sheet.
'Setting up for loop, currently range to loop over is J22:J(lastrow with data)
For Each rngCell In .Range(.Cells(22, 10), .Cells(Rows.Count, 10).End(xlUp))
'All values of the current row are combined into an array
'Determining and setting the range of the current row
Set rngRow = rngCell.Resize(1, 3)
'Populate a tmp array with the row range values
arrTmp = rngRow
'To use the array, it needs to be 1D, currently it is 2D, section below accomplishes this
'resize the final array
ReDim arrRow(LBound(arrTmp, 2) To UBound(arrTmp, 2))
'Copy values to final array
For i = LBound(arrTmp, 2) To UBound(arrTmp, 2)
arrRow(i) = arrTmp(1, i)
Next i
'the final array is combined to a single string value with " "(spaces) between each array element
'if the filterword is not found in the string Instr returns a 0
'If the filterword is found in the string InStr returns a number corresponding to the start position.
If InStr(1, Join(arrRow, " "), strFilterWord, vbTextCompare) = 0 Then
'Test to see if the range to delete is empty or not
If rngToDelete Is Nothing Then
'If the range is empty, it is set to the first row to delete.
Set rngToDelete = rngCell.EntireRow
Else
'if the range is not empty, the row to delete is added to the range.
Set rngToDelete = Union(rngToDelete, rngCell.EntireRow)
End If
End If
Next rngCell
'After all cells are looped over, the rows to delete are deleted in one go
If Not rngToDelete Is Nothing Then rngToDelete.Delete
End With
End Sub
Sub Button2_Click()
'Keep rows based on input
'Declaration of variables
Dim i As Long
Dim strFilterWord As String
Dim rngCell As Range
Dim rngToDelete As Range, rngRow As Range
Dim arrRow() As Variant, arrTmp() As Variant
'Setting the filter word
strFilterWord = InputBox("Enter a word by which you want to delete rows", "Enter")
With ThisWorkbook.Worksheets("Sheet1") 'Replace "Sheet1" with the actual name of your sheet.
'Setting up for loop, currently range to loop over is J22:J(lastrow with data)
For Each rngCell In .Range(.Cells(22, 10), .Cells(Rows.Count, 10).End(xlUp))
'All values of the current row are combined into an array
'Determining and setting the range of the current row
Set rngRow = rngCell.Resize(1, 3)
'Populate a tmp array with the row range values
arrTmp = rngRow
'To use the array, it needs to be 1D, currently it is 2D, section below accomplishes this
'resize the final array
ReDim arrRow(LBound(arrTmp, 2) To UBound(arrTmp, 2))
'Copy values to final array
For i = LBound(arrTmp, 2) To UBound(arrTmp, 2)
arrRow(i) = arrTmp(1, i)
Next i
'the final array is combined to a single string value with " "(spaces) between each array element
'if the filterword is not found in the string Instr returns a 0
'If the filterword is found in the string InStr returns a number corresponding to the start position.
If InStr(1, Join(arrRow, " "), strFilterWord, vbTextCompare) > 0 Then
'Test to see if the range to delete is empty or not
If rngToDelete Is Nothing Then
'If the range is empty, it is set to the first row to delete.
Set rngToDelete = rngCell.EntireRow
Else
'if the range is not empty, the row to delete is added to the range.
Set rngToDelete = Union(rngToDelete, rngCell.EntireRow)
End If
End If
Next rngCell
'After all cells are looped over, the rows to delete are deleted in one go
If Not rngToDelete Is Nothing Then rngToDelete.Delete
End With
End Sub
This should do the trick
Option Explicit
Sub DeletingRowContainingSpecificText()
Dim DataWorkSheet As Worksheet
'Change "ThisWorkBook" an "Sheet1" as you require
Set DataWorkSheet = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
Dim LastColumn As Long
With DataWorkSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
LastColumn = Columns(.Columns.Count).Column
End With
Dim word1 As String
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
Dim RowRange As Range
Dim RowReference As Long
Dim RowContent As String
Dim WordFound As Variant
'When ever you are deleting you need to start at the end and work your way back
'Otherwise the row after the row you deleted becomes the current row
For RowReference = LastRow To 22 Step -1
'Setting the Row Range from Column J to the end for a specific row
Set RowRange = ThisWorkbook.Worksheets("Sheet1").Range(Cells(RowReference, "J"), Cells(RowReference, LastColumn))
Set WordFound = RowRange.Find(What:=word1, LookIn:=xlValues)
If Not WordFound Is Nothing Then
'Choose if you want to delete or hidden
RowRange.EntireRow.Hidden = True
RowRange.EntireRow.Delete
End If
Next RowReference
End Sub
Just paste the Sub Content into your Button1_Click Sub. Otherwise paste this into your WorkBook Module and then test if it is working first.
I did test it and it worked for me.
NB when working with Deleting Rows or Columns always start at the end of the list and work your way to the beginning, this way the reference doesn't get messed up.
the problem resides in using Selection. You should avoid it at all costs!
If the data always is in the same region, this becomes quite simple. Try something like:
Sub Button1_Click()
Dim cell As Range
Dim rData as Range
'Assigns the range for J22 and adjacent rows and columns
Set rData = ActiveSheet.Range("J22").CurrentRegion
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
For Each cell In rData
If (InStr(1, cell, word1, 1) = 0) then cell.EntireRow.Delete
Next cell
End Sub
As you are not using Selection anymore, your 3 points get solved
I have an unsorted list of names in Sheet1, Column A. Many of these names appear more than once in the list.
On Sheet2 Column A I want an alphabetically sorted list of the names with no duplicate values.
What is the optimal method of achieving this using VBA?
Methods I have seen so far include:
Making a collection with CStr(name) as the key, looping through the range and trying to add each name; if there is an error it is not unique, ignore it, else expand the range by 1 cell and add the name
Same as (1), except ignore about the errors. When the loop is complete, only unique values will be in the collection: THEN add the whole collection to the range
Using the match worksheet function on the range: if no match, expand the range by one cell and add the name
Maybe some simulation of the "remove duplicates" button on the data tab? (haven't looked into this)
I really like the dictionary object in VBA. It's not natively available but it's very capable. You need to add a reference to Microsoft Scripting Runtime then you can do something like this:
Dim dic As Dictionary
Set dic = New Dictionary
Dim srcRng As Range
Dim lastRow As Integer
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Cells(1, 1).End(xlDown).Row
Set srcRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))
Dim cell As Range
For Each cell In srcRng
If Not dic.Exists(cell.Value) Then
dic.Add cell.Value, cell.Value 'key, value
End If
Next cell
Set ws = Sheets("Sheet2")
Dim destRow As Integer
destRow = 1
Dim entry As Variant
'the Transpose function is essential otherwise the first key is repeated in the vertically oriented range
ws.Range(ws.Cells(destRow, 1), ws.Cells(dic.Count, 1)) = Application.Transpose(dic.Items)
As you suggested, a dictionary of some sort is the key. I would use a Collection - it is builtin (in contrary to Scripting.Dictionary) and does the job.
If by "optimal" you mean "fast", the second trick is to not access each cell individually. Instead use a buffer. The below code will be fast even with thousands of rows of input.
Code:
' src is the range to scan. It must be a single rectangular range (no multiselect).
' dst gives the offset where to paste. Should be a single cell.
' Pasted values will have shape N rows x 1 column, with unknown N.
' src and dst can be in different Worksheets or Workbooks.
Public Sub unique(src As Range, dst As Range)
Dim cl As Collection
Dim buf_in() As Variant
Dim buf_out() As Variant
Dim val As Variant
Dim i As Long
' It is good practice to catch special cases.
If src.Cells.Count = 1 Then
dst.Value = src.Value ' ...which is not an array for a single cell
Exit Sub
End If
' read all values at once
buf_in = src.Value
Set cl = New Collection
' Skip all already-present or invalid values
On Error Resume Next
For Each val In buf_in
cl.Add val, CStr(val)
Next
On Error GoTo 0
' transfer into output buffer
ReDim buf_out(1 To cl.Count, 1 To 1)
For i = 1 To cl.Count
buf_out(i, 1) = cl(i)
Next
' write all values at once
dst.Resize(cl.Count, 1).Value = buf_out
End Sub