Sort Combobox VBA - vba

I have been thinking how to sort the values in a combobox.
I add items to the ComboBox when I initilize the form because the number of values are constantly increasing on a sheet.
I use the next code to add the items:
With ComboBox1
lastcell = ThisWorkbook.Sheets("1").Range("F1000000").End(xlUp).Row + 1
For i = 2 To lastcell
.AddItem ThisWorkbook.Sheets("1").Cells(i, 6)
Next i
End With
I thought to copy the values that I am going to add on the ComoBox to another sheet and there sort them in the new sheet, it works fine but it doesn't seem to be a smart option, meaning that I create another sheet and then copy the values and sort them instead of sorting them directly.
My question is, anyone knows how to do it directly from the original sheet? I dont know anything of API so, please, only VBA code. I alredy check on MSDN but I can't figure out how to make it work.
Thanks and if more info is needed, please, let me know it.
PS: I cant sort them directly from the original sheet because this Sheet has to be with a static order

You can read the values from the sheet into an array, sort this with code and then add the items.
This code will do this, using a Quicksort:
Private Sub UserForm_Initialize()
Dim varRange() As Variant
Dim lngLastRow As Long
Dim i As Long
lngLastRow = Range("F:F").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
varRange = Range("F:F").Resize(lngLastRow).Cells
subQuickSort varRange
Me.ComboBox1.List = varRange
End Sub
Public Sub subQuickSort(var1 As Variant, _
Optional ByVal lngLowStart As Long = -1, _
Optional ByVal lngHighStart As Long = -1)
Dim varPivot As Variant
Dim lngLow As Long
Dim lngHigh As Long
lngLowStart = IIf(lngLowStart = -1, LBound(var1), lngLowStart)
lngHighStart = IIf(lngHighStart = -1, UBound(var1), lngHighStart)
lngLow = lngLowStart
lngHigh = lngHighStart
varPivot = var1((lngLowStart + lngHighStart) \ 2, 1)
While (lngLow <= lngHigh)
While (var1(lngLow, 1) < varPivot And lngLow < lngHighStart)
lngLow = lngLow + 1
Wend
While (varPivot < var1(lngHigh, 1) And lngHigh > lngLowStart)
lngHigh = lngHigh - 1
Wend
If (lngLow <= lngHigh) Then
subSwap var1, lngLow, lngHigh
lngLow = lngLow + 1
lngHigh = lngHigh - 1
End If
Wend
If (lngLowStart < lngHigh) Then
subQuickSort var1, lngLowStart, lngHigh
End If
If (lngLow < lngHighStart) Then
subQuickSort var1, lngLow, lngHighStart
End If
End Sub
Private Sub subSwap(var As Variant, lngItem1 As Long, lngItem2 As Long)
Dim varTemp As Variant
varTemp = var(lngItem1, 1)
var(lngItem1, 1) = var(lngItem2, 1)
var(lngItem2, 1) = varTemp
End Sub

It depends on circumstances, type and structure of data. But i prefer to do it this way:
You could alternatively use an array and a bubble sort algo :)
modify the code a little bit to suit your case
Option Explicit
Sub WITH_COMBOBOX()
Dim i As Long
Dim arr() As String
Dim lastCell As Long
lastCell = 500
ReDim arr(lastCell)
Call FillAndSortArray(arr)
For i = 2 To lastCell
.AddItem arr(i - 2)
Next i
End Sub
Sub FillAndSortArray(ByRef myArray() As String)
Dim i As Long
For i = LBound(myArray) To UBound(myArray)
myArray(i) = CStr(ThisWorkbook.Sheets(1).Range("F" & i + 2).Value)
Next i
Call BubbleSort(myArray)
End Sub
Sub BubbleSort(ByRef myArray() As String)
Dim i As Long, j As Long
Dim Temp As String
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray) - 1
If myArray(i) > myArray(j) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
End Sub

Try below code :
Sub GetAction()
Dim rng As Range, lastcell As Long
lastcell = Range("F1000").End(xlUp).Row + 1
Set rng = Range("F1:F" & lastcell) ' assuming to start from F1
If Not rng Is Nothing Then
rng.Sort Range("F1")
ComboBox1.ListFillRange = rng.Address
End If
End Sub

for sorting 123 for number
For Each cell In ThisWorkbook.Sheets("sheet1").Range("list1")
Me.ComboBox1.AddItem cell
Next cell
With Me.ComboBox1
For x = LBound(.list) To UBound(.list)
For y = x To UBound(.list)
If .list(y, 0) + 0 < .list(x, 0) + 0 Then
blah = .list(y, 0)
.list(y, 0) = .list(x, 0)
.list(x, 0) = blah
End If
Next y
Next x
End With
for sorting text abcd
For Each cell In ThisWorkbook.Sheets("sheet1").Range("list1")
Me.ComboBox1.AddItem cell
Next cell
With Me.ComboBox1
For x = LBound(.list) To UBound(.list)
For y = x To UBound(.list)
If .list(y, 0) < .list(x, 0) Then
blah = .list(y, 0)
.list(y, 0) = .list(x, 0)
.list(x, 0) = blah
End If
Next y
Next x
End With

Related

Improvement on 3 Criteria Vlookup macro

I have a list with 3 variables in the sheet "Combined" in columns A; B; C.
The workbook contains 98 sheets, with those 3 variables still in A; B; C columns but in different combinations and with a fourth column which never repeats itself, as the sheets go on, which i need to bring in the "Combined" sheet, always adding another column for the next sheet I vlookup. : A B C + D(from the next sheet) + E(from the next sheet) and so on.
I have a UDF that Vlookups on 3 based on 3 criterias and a macro that cycles through the sheets and bring the values where i want them. The problem is, it's pretty slow, left it from yesterday and its on sheet 60. Any suggestions on improving it would greatly help, Thank you in advance!
Function ThreeVlookup(Table_Range As Range, Return_Col As Long, Col1_Fnd, Col2_Fnd, Col3_Fnd)
Dim rCheck As Range, bFound As Boolean, lLoop As Long
On Error Resume Next
Set rCheck = Table_Range.Columns(1).Cells(1, 1)
With WorksheetFunction
For lLoop = 1 To .CountIf(Table_Range.Columns(1), Col1_Fnd)
Set rCheck = Table_Range.Columns(1).Find(Col1_Fnd, rCheck, xlValues, xlWhole, xlNext, xlRows, False)
If UCase(rCheck(1, 2)) = UCase(Col2_Fnd) And UCase(rCheck(1, 3)) = UCase(Col3_Fnd) Then
bFound = True
Exit For
End If
Next lLoop
End With
If bFound = True Then
ThreeVlookup = rCheck(1, Return_Col)
Else
ThreeVlookup = ""
End If
End Function
Sub test()
Dim lookupVal1 As Range, lookupVal2 As Range, lookupVal3 As Range, myString As Variant, n&, u As Long
n = Sheets("Combined").[A:A].Cells.Find("*", , , , xlByRows, xlPrevious).Row
u = 4
For j = 2 To Worksheets.Count
For i = 1 To n
Set lookupVal1 = Sheets("Combined").Cells(i, 1)
Set lookupVal2 = Sheets("Combined").Cells(i, 2)
Set lookupVal3 = Sheets("Combined").Cells(i, 3)
myString = ThreeVlookup(Sheets(j).Range("A:D"), 4, lookupVal1, lookupVal2, lookupVal3)
Sheets("Combined").Cells(i, u) = myString
Next i
u = u + 1
Next j
End Sub
Use Arrays to speed it up, my friend! Load all your sheets (or just the current sheet in the loop) into an array in VBA's memory and do the .CountIf and .Find on arrayVar(row) instead of Table_Range.Columns(1).
You will be really surprised how much quicker it goes. Do it!
Here's a tutorial I like on arrays...
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Here's a guy who speed-tested an application like yours...
https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/
The basics is like this:
Sub Play_With_Arrays()
Dim varArray() As Variant
Dim lngArray() As Long
ReDim varArray(1 To 1000)
ReDim lngArray(1 To 1000)
For A = 1 To 1000
lngArray(A) = A / 2
varArray(A) = A / 2 & " examples"
Next
searchterm = 345
For B = 1 To 1000
If lngArray(B) = searchterm Then
FoundRow = B
End If
Next
searchterm2 = "5 ex"
FoundStrRowCount = 0
For C = 1 To 1000
If InStr(1, varArray(C), searchterm2, vbBinaryCompare) Then
FoundStrRowCount = FoundStrRowCount + 1
End If
Next
MsgBox (FoundRow & " in long array and " & FoundStrRowCount & " in var array")
End Sub
Something like this should be much faster:
Public Function ThreeVLookup(ByVal arg_Col1LookupVal As Variant, _
ByVal arg_Col2LookupVal As Variant, _
ByVal arg_Col3LookupVal As Variant, _
ByVal arg_LookupTable As Range, _
ByVal arg_ReturnColumn As Long) _
As Variant
Dim rConstants As Range, rFormulas As Range
Dim rAdjustedTable As Range
Dim aTable As Variant
Dim i As Long
On Error Resume Next
Set rConstants = arg_LookupTable.SpecialCells(xlCellTypeConstants)
Set rFormulas = arg_LookupTable.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case (Not rConstants Is Nothing) + 2 * (Not rFormulas Is Nothing)
Case 0: ThreeVLookup = vbNullString
Exit Function
Case -1: Set rAdjustedTable = rConstants
Case -2: Set rAdjustedTable = rFormulas
Case -3: Set rAdjustedTable = Union(rConstants, rFormulas)
End Select
If WorksheetFunction.CountIfs(rAdjustedTable.Resize(, 1), arg_Col1LookupVal, rAdjustedTable.Resize(, 1).Offset(, 1), arg_Col2LookupVal, rAdjustedTable.Resize(, 1).Offset(, 2), arg_Col3LookupVal) = 0 Then
ThreeVLookup = vbNullString
Exit Function
End If
aTable = rAdjustedTable.Value
For i = LBound(aTable, 1) To UBound(aTable, 1)
If aTable(i, 1) = arg_Col1LookupVal And aTable(i, 2) = arg_Col2LookupVal And aTable(i, 3) = arg_Col3LookupVal Then
ThreeVLookup = aTable(i, arg_ReturnColumn)
Exit Function
End If
Next i
End Function
Sub tgr()
Dim wb As Workbook
Dim wsCombined As Worksheet
Dim ws As Worksheet
Dim aResults() As Variant
Dim aCombined As Variant
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsCombined = wb.Sheets("Combined")
aCombined = wsCombined.Range("A1").CurrentRegion.Value
ReDim aResults(1 To UBound(aCombined, 1) - LBound(aCombined, 1) + 1, 1 To wb.Sheets.Count - 1)
For i = LBound(aCombined, 1) To UBound(aCombined, 1)
j = 0
For Each ws In wb.Sheets
If ws.Name <> wsCombined.Name Then
j = j + 1
aResults(i, j) = ThreeVLookup(aCombined(i, 1), aCombined(i, 2), aCombined(i, 3), ws.Range("A:D"), 4)
End If
Next ws
Next i
wsCombined.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub

Excel VBA - Auto FIlter and Advanced filter usage error

I have a requirement where in, I need to use the auto filter to filter the data first and then am using the advanced filter to get the Unique values alone. But the advanced filter doesn't take the auto filtered value alone. How do I use them together?
Here goes my code,
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0)
ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES"
ActiveSheet.Range("B1:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("CSRS").Range("B14"), Unique:=True
Kindly correct me and share your suggestions. Thanks
I would stick the unique values in an array - it's faster and less likely to break -
sub uniquearray()
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0)
ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES"
Call creatary(curary, Sheets("RS_Report"), Letter(Sheets("RS_Report"), "RSDate")): Call eliminateDuplicate(curary): Call BuildArrayWithoutBlankstwo(curary): Call Alphabetically_SortArray(curary)
For Each cell In curary
'do what you need to do with the unique array list
Next cell
end sub
Function creatary(ary As Variant, sh As Worksheet, ltr As String)
Dim x, y, rng As Range
ReDim ary(0)
Set rng = sh.Range(ltr & "2:" & ltr & sh.Range("A1000000").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
x = 0
For Each y In rng
If Not Application.IsError(y) Then
If Not IsNumeric(y) Then
ary(x) = y
End If
x = x + 1
ReDim Preserve ary(x)
End If
Next y
End Function
Function BuildArrayWithoutBlankstwo(ary As Variant)
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ary
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If ary(Counter) <> 0 Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = ary(Counter)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
ary = AryNoBlanks
End Function
Function eliminateDuplicate(ary As Variant) As Variant
Dim aryNoDup(), dupArrIndex, i, dupBool, j
dupArrIndex = -1
For i = LBound(ary) To UBound(ary)
dupBool = False
For j = LBound(ary) To i
If ary(i) = ary(j) And Not i = j Then
dupBool = True
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve aryNoDup(dupArrIndex)
aryNoDup(dupArrIndex) = ary(i)
End If
Next i
ary = aryNoDup
End Function
Function Alphabetically_SortArray(ary)
Dim myArray As Variant
Dim x As Long, y As Long
Dim TempTxt1 As String
Dim TempTxt2 As String
myArray = ary
'Alphabetize Sheet Names in Array List
For x = LBound(myArray) To UBound(myArray)
For y = x To UBound(myArray)
If UCase(myArray(y)) < UCase(myArray(x)) Then
TempTxt1 = myArray(x)
TempTxt2 = myArray(y)
myArray(x) = TempTxt2
myArray(y) = TempTxt1
End If
Next y
Next x
ary = myArray
End Function
Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function

Sort range without sorting it in a spreadsheet

Question is about sorting data in VBA. Suppose I have a Range("A1:A10") which I want to sort in ascending order. However, I do not want any changes in my spreadsheet (so all the calculations are made within a VBA code). The output of the operation should be a NewRange where all the numbers are sorted.
Has someone ideas about this problem?
Here is a very simple little routine to sort a two-dimensional array such as a range:
Option Base 1
Option Explicit
Function SortThisArray(aryToSort)
Dim i As Long
Dim j As Long
Dim strTemp As String
For i = LBound(aryToSort) To UBound(aryToSort) - 1
For j = i + 1 To UBound(aryToSort)
If aryToSort(i, 1) > aryToSort(j, 1) Then
strTemp = aryToSort(i, 1)
aryToSort(i, 1) = aryToSort(j, 1)
aryToSort(j, 1) = strTemp
End If
Next j
Next i
SortThisArray = aryToSort
End Function
How to use this sort function:
Sub tmpSO()
Dim aryToSort As Variant
aryToSort = Worksheets(1).Range("C3:D9").Value2 ' Input
aryToSort = SortThisArray(aryToSort) ' sort it
Worksheets(1).Range("G3:H9").Value2 = aryToSort ' Output
End Sub
Notes:
The range sorted here is on Worksheet(1) in the Range("C3:D9") and the output is going on the same sheet into Range("G3:H9")
The range will be sorted in ascending order.
The range will be sorted based on the first column (here column C). If you wish to sort for another column then you just have to change all the aryToSort(i, 1) and aryToSort(j, 1) to which ever column you wish to sort. For example by column 2: aryToSort(i, 2) and aryToSort(j, 2).
UPDATE:
If you prefer to use the above as a function then this is also possible like this:
Option Base 1
Option Explicit
Function SortThisArray(rngToSort As range)
Dim i As Long
Dim j As Long
Dim strTemp As String
Dim aryToSort As Variant
aryToSort = rngToSort.Value2
For i = LBound(aryToSort) To UBound(aryToSort) - 1
For j = i + 1 To UBound(aryToSort)
If aryToSort(i, 1) > aryToSort(j, 1) Then
strTemp = aryToSort(i, 1)
aryToSort(i, 1) = aryToSort(j, 1)
aryToSort(j, 1) = strTemp
End If
Next j
Next i
SortThisArray = aryToSort
End Function
And this is how you would use the function:
This is just a sample that you may adapt to your needs, it uses B11:B20 as NewRange:
Sub SortElseWhere()
Dim A As Range, NewRange As Range
Set A = Range("A1:A10")
Set NewRange = Range("B11:B20")
A.Copy NewRange
NewRange.Sort Key1:=NewRange(1, 1), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
The original cells are not sorted, they are merely copied to another location which is sorted.
EDIT#1:
In this version, NewRange is not a range of cells, but an internal array:
Sub SortElseWhere2()
Dim A As Range, NewRange(1 To 10) As Variant
Dim i As Long, strng As String
i = 1
Set A = Range("A1:A10")
For Each aa In A
NewRange(i) = aa
i = i + 1
Next aa
Call aSort(NewRange)
strng = Join(NewRange, " ")
MsgBox strng
End Sub
Public Sub aSort(ByRef InOut)
Dim i As Long, J As Long, Low As Long
Dim Hi As Long, Temp As Variant
Low = LBound(InOut)
Hi = UBound(InOut)
J = (Hi - Low + 1) \ 2
Do While J > 0
For i = Low To Hi - J
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
For i = Hi - J To Low Step -1
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
J = J \ 2
Loop
End Sub
Here I am submitting slightly different sort routine.It sorts the 2nd column first then 1st column.
Function BubbleSort(TempArray() As Variant, SortIndex As Long)
Dim blnNoSwaps As Boolean
Dim lngItem As Long
Dim vntTemp(1 To 2) As Variant
Dim lngCol As Long
Do
blnNoSwaps = True
For lngItem = LBound(TempArray) To UBound(TempArray) - 1
If TempArray(lngItem, SortIndex) > TempArray(lngItem + 1, SortIndex) Then
blnNoSwaps = False
For lngCol = 1 To 2
vntTemp(lngCol) = TempArray(lngItem, lngCol)
TempArray(lngItem, lngCol) = TempArray(lngItem + 1, lngCol)
TempArray(lngItem + 1, lngCol) = vntTemp(lngCol)
Next
End If
Next
Loop While Not blnNoSwaps
End Function
Sub Test()
Dim vntData() As Variant
vntData = range("C3:D9")
BubbleSort vntData, 2
BubbleSort vntData, 1
range("G3:H9") = vntData
End Sub
Results obtained from this routine are shown below.

How to color cell in excel using vb.net?

How to color cells vertically? Example I want to color all data in cell"I" up to the last.
here what I've tried so far:
For i = 0 To ds.Tables(0).Rows.Count - 1
For j = 0 To ds.Tables(0).Columns.Count - 1
xlSheet.Cells(i + 8, j + 1) =
ds.Tables(0).Rows(i).Item(j)
formatRange = xlSheet.Cells(i + 8, j + 1)
formatRange.BorderAround(Excel.XlLineStyle.xlDash, Excel.XlBorderWeight.xlThin, Excel.XlColorIndex.xlColorIndexAutomatic, Excel.XlColorIndex.xlColorIndexAutomatic)
formatRange = xlSheet.Cells(i + 8, 9 + j)
formatRange.Interior.Color = system.Drawing.ColorTranslator.ToOle(system.Drawing.Color.Red)
Next
Next
Doesn't this work for you:
xlSheet.Range("I:I").Interior.Color = System.Drawing.ColorTranslator.ToOle(system.Drawing.Color.Red)
This will do it for you.
Sub ColorCol(ColID As String, R As Long, G As Long, B As Long)
Dim LastRow As Long
Dim Rr As Range
With ThisWorkbook.ActiveSheet
LastRow = .Cells(.Rows.Count, ColID).End(xlUp).Row
Set Rr = .Range(ColID & "1", ColID & LastRow)
For Each Cell In Rr.Cells
Cell.Interior.Color = RGB(R, G, B)
Next
End With
End Sub
Sub Main()
ColorCol "A", 255, 0, 0
End Sub
Calling it from another sub
Sub Main()
ColorCol "A",255,0,0
End Sub
Nota: Works on your Active Sheet

excel vba - remove cell from a variant based on blank in another column

i have an excel sheet like so:
HEADING <--A1 HEADING <-- this is B1
dhg kfdsl
56 fdjgnm
hgf fdkj
tr
465 gdfkj
gdf53
ry 4353
654 djk
354 <-- a12 blah <-- this is B12
I'm trying to put the range of cells in column A into a variant and remove any data from that variant if the cell in column B (for the same row in column A) is blank. Then i want to copy that variant to a new column (ie col c)
so my expected result is:
HEADING <--C1
dhg
56
hgf
465
ry
654
354 <-- C8
this is the code i have so far:
Dim varData As Variant
Dim p As Long
varData = originsheet.Range("B2:B12")
For p = LBound(varData, 1) To UBound(varData, 1)
If IsEmpty(varData(p, 1)) Then
remove somehow
End If
Next p
Dim bRange As range
Set bRange = originsheet.range("B2:B12")
Dim aCell, bCell, cCell As range
Set cCell = originsheet.Cells(2, 3) 'C2
For Each bCell In bRange
If bCell.Text <> "" Then
Set aCell = originsheet.Cells(bCell.Row, 1)
cCell.Value2 = aCell.Value2
Set cCell = originsheet.Cells(cCell.Row + 1, 3)
End If
Next bCell
Personally, I think your making this simple job harder, but here's how to do it the way you wanted:
Public Sub Test()
Dim Arange As Variant, Brange As Variant, Crange() As Variant
Dim i As Integer, j As Integer
Arange = Range("A2:A12")
Acount = Application.WorksheetFunction.CountA(Range("B2:B12"))
Brange = Range("B2:B12")
j = 1
ReDim Crange(1 To Acount, 1 To 1)
For i = 1 To UBound(Arange)
If Brange(i, 1) <> "" Then
Crange(j, 1) = Arange(i, 1)
j = j + 1
End If
Next i
Range("C2:C" & j) = Crange
End Sub
Try:
With ActiveSheet.UsedRange
.Cells(2, "C").Resize(.Rows.Count).Value = Cells(2, "A").Resize(.Rows.Count).Value
.Cells(2, "B").Resize(.Rows.Count).SpecialCells(xlCellTypeBlanks).Offset(, 1).Delete shift:=xlUp
End With
EDIT:
This is better:
With Range("A2", Cells(Rows.Count, "A").End(xlUp))
Cells(2, "C").Resize(.Rows.Count).Value = .Value
.Offset(, 1).SpecialCells(xlCellTypeBlanks).Offset(, 1).Delete shift:=xlUp
End With
You could also do it with advanced filter and no VBA.
Sub Main()
Dim rValues As Range
Dim vaIn As Variant
Dim vaTest As Variant
Dim aOut() As Variant
Dim i As Long
Dim lCnt As Long
Set rValues = Sheet1.Range("A2:A12")
vaIn = rValues.Value
vaTest = rValues.Offset(, 1).Value
ReDim aOut(1 To Application.WorksheetFunction.CountA(rValues.Offset(, 1)), 1 To 1)
For i = LBound(vaIn, 1) To UBound(vaIn, 1)
If Len(vaTest(i, 1)) <> 0 Then
lCnt = lCnt + 1
aOut(lCnt, 1) = vaIn(i, 1)
End If
Next i
Sheet1.Range("C2").Resize(UBound(aOut, 1)).Value = aOut
End Sub