Related
I am writing a VBA code on excel using loops to go through 10000+ lines.
Here is an example of the table
And here is the code I wrote :
Sub Find_Matches()
Dim wb As Workbook
Dim xrow As Long
Set wb = ActiveWorkbook
wb.Worksheets("Data").Activate
tCnt = Sheets("Data").UsedRange.Rows.Count
Dim e, f, a, j, h As Range
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
For xrow = 2 To tCnt Step 1
Set e = Range("E" & xrow)
Set f = e.Offset(0, 1)
Set a = e.Offset(0, -4)
Set j = e.Offset(0, 5)
Set h = e.Offset(0, 3)
For Each Cell In Range("E2:E" & tCnt)
If Cell.Value = e.Value Then
If Cell.Offset(0, 1).Value = f.Value Then
If Cell.Offset(0, -4).Value = a.Value Then
If Cell.Offset(0, 5).Value = j.Value Then
If Cell.Offset(0, 3).Value = h.Value Then
If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
Cell.EntireRow.Interior.Color = vbYellow
e.EntireRow.Interior.Color = vbYellow
End If
End If
End If
End If
End If
End If
Next
Next
End Sub
As you can imagine, this is taking a lot of time to go through 10000+ lines and I would like to find a faster solution. There must be a method I don't think to avoid the over looping
Here are the condition :
For each line, if another line anywhere in the file has the exact same
:
Buyer ID (col. E)
`# purchased (col. F)
Product ID (col.A)
Payment (col. J)
Date purchased (col. H)
Then, if the SUM of the Amount (col. L) the those two matching line is
0, then color both rows in yellow.
Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.
Running the previous code, in my example, row 2 & 5 get highlighted :
This is using nested dictionaries and arrays to check all conditions
Timer with my test data: Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec
Option Explicit
Public Sub FindMatches()
Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12
Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object
Set ur = ThisWorkbook.Worksheets("Data").UsedRange
x = ur
Set d = CreateObject("Scripting.Dictionary")
Set found = CreateObject("Scripting.Dictionary")
Dim r As Long, rId As String, itm As Variant, dupeRows As Object
For r = ur.Row To ur.Rows.Count
rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
If Not d.Exists(rId) Then
Set dupeRows = CreateObject("Scripting.Dictionary")
dupeRows(r) = 0
Set d(rId) = dupeRows
Else
For Each itm In d(rId)
If x(r, L) + x(itm, L) = 0 Then
found(r) = 0
found(itm) = 0
End If
Next
End If
Next
Application.ScreenUpdating = False
For Each itm In found
ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub
Before
After
I suggest a different approach altogether: add a temporary column to your data that contains a concatenation of each cell in the row. This way, you have:
A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A
Then use Excel's conditional formatting on the temporary column, highlighting duplicate values. There you have your duplicated rows. Now it's only a matter of using a filter to check which ones have amounts equal to zero.
You can use the CONCATENATE function; it requires you to specify each cell separately and you can't use a range, but in your case (comparing only some of the columns) it seems like a good fit.
Maciej's answer is easy to implement (if you can add columns to your data without interrupting anything), and I would recommend it if possible.
However, for the sake of answering your question, I will contribute a VBA solution as well. I tested it on dataset that is a bit smaller than yours, but I think it will work for you. Note that you might have to tweak it a little (which row you start on, table name, etc) to fit your workbook.
Most notably, the segment commented with "Helper column" is something you most likely will have to adjust - currently, it compares every cell between A and H for the current row, which is something you may or may not want.
I've tried to include a little commentary in the code, but it's not much. The primary change is that I'm using in-memory processing of an array rather than iterating over a worksheet range (which for larger datasets should be exponentially faster).
Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime
Sub Find_Matches()
Dim wb As Workbook, ws As Worksheet
Dim xrow As Long, tCnt As Long
Dim e As Range, f As Range, a As Range, j As Range, h As Range
Dim sheetArr() As Variant, arr() As Variant
Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
Dim arrSize As Long, i As Long, k As Long
Dim c As Variant
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Data")
ws.Activate
tCnt = ws.UsedRange.Rows.Count
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Read range into an array so we process in-memory
sheetArr = ws.Range("A2:H" & tCnt)
arrSize = UBound(sheetArr, 1)
' Build new arr with "helper column"
ReDim arr(1 To arrSize, 1 To 9)
For i = 1 To arrSize
For k = 1 To 8
arr(i, k) = sheetArr(i, k)
arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
Next k
Next i
' Iterate over array & build collection to indicate yellow lines
For i = LBound(arr, 1) To UBound(arr, 1)
If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
For Each c In colorResults
If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
Next c
Next i
' Enact row colors
For Each dictItem In colorTheseYellow
'Debug.Print "dict: "; dictItem
If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
Next dictItem
End Sub
Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
' Returns "0;0" if 1 or fewer matches
Dim i As Long
Dim j As Long
Dim tmp As String
ReturnLines = 0
j = 0
tmp = "0"
'Debug.Print "arg: " & s
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 9) = s Then
j = j + 1
'Debug.Print "arr: " & arr(i, 9)
'Debug.Print "ReturnLine: " & i
tmp = tmp & ";" & CStr(i)
End If
Next i
'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)
'Debug.Print "tmp: " & tmp
If j >= 2 Then
ReturnLines = tmp
Else
ReturnLines = "0;0"
End If
End Function
On my simple dataset, it yields this result (marked excellently with freehand-drawn color indicators):
Thanks everybody for your answers,
Paul Bica's solution actually worked and I am using a version of this code now.
But, just to animate the debate, I think I also found another way around my first code, inspired by Maciej's idea of concatenating the cells and using CStr to compare the values and, of course Vegard's in-memory processing by using arrays instead of going through the workbook :
Sub Find_MatchesStr()
Dim AmountArr(300) As Variant
Dim rowArr(300) As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set ws = ThisWorkbook.Sheets("Data")
ws.Activate
Range("A1").Select
rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To rCnt
If i = rCnt Then
Exit For
Else
intCnt = 0
strA = ws.Cells(i, 1).Value
strE = ws.Cells(i, 5).Value
strF = ws.Cells(i, 6).Value
strH = ws.Cells(i, 8).Value
strL = ws.Cells(i, 10).Value
For j = i To rCnt - 1
strSearchA = ws.Cells(j, 1).Value
strSearchE = ws.Cells(j, 5).Value
strSearchF = ws.Cells(j, 6).Value
strSearchH = ws.Cells(j, 8).Value
strSearchL = ws.Cells(j, 10).Value
If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then
AmountArr(k) = ws.Cells(j, 12).Value
rowArr(k) = j
intCnt = intCnt + 1
k = k + 1
Else
Exit For
End If
Next
strSum = 0
For s = 0 To UBound(AmountArr)
If AmountArr(s) <> "" Then
strSum = strSum + AmountArr(s)
Else
Exit For
End If
Next
strAppenRow = ""
For b = 0 To UBound(rowArr)
If rowArr(b) <> "" Then
strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
Else
Exit For
End If
Next
If intCnt = 1 Then
Else
If strSum = 0 Then
For rn = 0 To UBound(rowArr)
If rowArr(rn) <> "" Then
Let rRange = rowArr(rn) & ":" & rowArr(rn)
Rows(rRange).Select
Selection.Interior.Color = vbYellow
Else
Exit For
End If
Next
Else
strvar = ""
strvar = Split(strAppenRow, ",")
For ik = 1 To UBound(strvar)
If strvar(ik) <> "" Then
strVal = CDbl(strvar(ik))
For ik1 = ik To UBound(strvar)
If strvar(ik1) <> "" Then
strVal1 = CDbl(strvar(ik1))
If strVal1 + strVal = 0 Then
Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
Rows(sRange1).Select
Selection.Interior.Color = vbYellow
Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
Rows(sRange).Select
Selection.Interior.Color = vbYellow
End If
Else
Exit For
End If
ik1 = ik1 + 1
Next
Else
Exit For
End If
ik = ik + 1
Next
End If
End If
i = i + (intCnt - 1)
k = 0
Erase AmountArr
Erase rowArr
End If
Next
Range("A1").Select
End Sub
I still have some mistakes (rows not higlighted when they should be), the above code is not perfect, but I thought it'd be OK to give you an idea of where I was going before Paul Bica's solution came in.
Thanks again !
If your data is only till column L, then use below code, I found it is taking less time to run....
Sub Duplicates()
Application.ScreenUpdating = False
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("O2") = "=A2&E2&F2&J2&L2"
Range("P2") = "=COUNTIF(O:O,O2)"
Range("O2:P" & lrow).FillDown
Range("O2:O" & lrow).Copy
Range("O2:O" & lrow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
For i = 1 To lrow
If Cells(i, 16) = 2 Then
Cells(i, 16).EntireRow.Interior.Color = vbYellow
End If
Next
Application.ScreenUpdating = True
Range("O:P").Delete
Range("A1").Select
MsgBox "Done"
End Sub
What I need help on is to copy the previous cells text into the cell below it and add the letter A at the end of it i.e. before VP0007 after VP0007A. This should continue until all the blank cells have been incremented and it reaches the next VP0008.
Please see the images. I apologise if I am not too clear.
Before: After:
Right now I have the following code:
ActiveCell.Offset(1, 0).Select
Letter = "A"
Letters = Chr(Asc(Letter) + 1)
Number = ActiveCell.Offset(-1, 0).Value
If ActiveCell.Value = Number & Letter _ Then
ActiveCell.Offset(1, 0).Select.Value Number & Number
Else
ActiveCell.Value = Number & Letters
End If
Loop Until ActiveCell.Offset(1, 0).Value <> ""
Try this short sub procedure.
Sub fillSubseries()
Dim i As Long, a As Long, str As String
With Worksheets("sheet4")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If IsEmpty(.Cells(i, "A")) Then
.Cells(i, "A") = str & Chr(a)
a = a + 1
Else
a = 65
str = .Cells(i, "A").Value2
End If
Next i
End With
End Sub
Try using the below code
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Letter = "A"
For iLoop = 2 To LastRow
If ActiveSheet.Range("A" & iLoop) = "" Then
iValue = ActiveSheet.Range("A" & iLoop - 1)
iiLoop = iLoop
Do
If ActiveSheet.Range("A" & iiLoop) = "" Then
ActiveSheet.Range("A" & iiLoop) = iValue & Letter
Letter = Chr(Asc(Letter) + 1)
Else
Letter = "A"
Exit Do
End If
iiLoop = iiLoop + 1
Loop
iLoop = iiLoop - 1
End If
Next
This code should handle cases where you have more than 26 blank rows and increment past the letter "Z".
Sub FillBlanks()
Dim lastRow As Long, cnt As Long, i As Long
Dim prevItem As String
Dim ws As Worksheet
Set ws = ActiveSheet
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
prevItem = ws.Cells(2, 1).Value
cnt = 0
For i = 2 To lastRow
If ws.Cells(i, 1) = "" Then
cnt = cnt + 1
ws.Cells(i, 1).Value = prevItem & Split(Cells(1, cnt).Address(True, False), "$")(0)
Else
prevItem = ws.Cells(i, 1)
cnt = 0
End If
Next i
End Sub
Alternate:
Sub tgr()
Dim ws As Worksheet
Dim aData As Variant
Dim sTemp As String
Dim sLetter As String
Dim i As Long, j As Long
Set ws = ActiveWorkbook.ActiveSheet
With ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
aData = .Value
End With
For i = LBound(aData, 1) To UBound(aData, 1)
If Len(Trim(aData(i, 1))) > 0 Then
sTemp = Trim(aData(i, 1))
j = 0
Else
j = j + 1
sLetter = Replace(ws.Cells(1, j).Address(0, 0), 1, vbNullString)
aData(i, 1) = sTemp & sLetter
End If
Next i
ws.Range("A2").Resize(UBound(aData, 1)).Value = aData
End Sub
If you need a pure formula solution, you may try below steps (The first row of your data should be A2, not A1):
First we need a dummy column in order to fill in the blank rows. Use below formula on B2 and copy it down through the last row of column A:
=IF(A2<>"",A2,B1)
Then we will create the final values on column C. Add below formula to C2 and copy down:
=IF(A2<>"",A2,IF(ISNUMBER(VALUE(RIGHT(C1,1)))=TRUE,C1&"A",B2&CHAR(CODE(RIGHT(C1,1))+1)))
Basically we first filled in the blank rows with repeating values on column B. Then copied Col:A value to Col:C if Col:A is not blank. If Col:A is blank and upper row (Col:C) value's last character is numeric we add "A" to that value. If the last character is a letter than we concatenate the next letter with Col:B value.
You should have something like below, when everything is OK:
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
I'm trying to figure out how to start an autofill based on a dynamic range. For each column in the 'starting table' I need to stack them on top of one another. My current code starting at 'LastRow' does not do this. I was hoping LastRow would give me a dynamic Range to autofill from, but instead I get the error,
'Object variable or With block variable not set'
How do I change my code so that '2Move' autofills to the new size of the table, without knowing where it starts? Then repeat the process for '3Move' and '4Move'
Sub shiftingColumns()
Dim sht As Worksheet
Dim LastRow As Range
Set sht = ActiveSheet
Set copyRange = Sheets("Sheet1").Range(Range("A2:B2"), Range("A2:B2").End(xlDown))
'Insert column & add header
Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Value = "Category"
'Move D1 Value to C2
Range("D1").Cut Destination:=Range("C2")
'Autofill C2 value to current table size
Range("C2").AutoFill Destination:=Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
'Copy copyRange below itself
copyRange.Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
'Move E1 below autofilled ranged
Range("E1").Cut Destination:=Range("C" & Rows.Count).End(xlUp).Offset(1)
'LastRow = sht.Cells(sht.Rows.Count, "C").End(xlUp).Row
'LastRow.AutoFill Destination:=Range(LastRow & Range("A" & Rows.Count).End(xlUp).Row)
End Sub
This is the starting table
This is the desired table
For the benefit of those finding this via search engine, what you're looking to do isn't anything like autofill.
This should work for you, a loop.
Sub test()
workingSheet = ActiveSheet.Name
newSheet = "New Sheet"
On Error Resume Next
Application.DisplayAlerts = False
Sheets(newSheet).Delete
Application.DisplayAlerts = True
Sheets.Add.Name = newSheet
Cells(1, 1) = "ID"
Cells(1, 2) = "Color"
Cells(1, 3) = "Category"
On Error GoTo 0
Sheets(workingSheet).Activate
'Get last column
x = Cells(1, 3).End(xlToRight).Column
y = Cells(1, 1).End(xlDown).Row
'Loop for each column from 3 (column "C") and after
For i = 3 To x
With Sheets(newSheet)
newRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
'Copy ID and Color
Range(Cells(2, 1), Cells(y, 2)).Copy .Range(.Cells(newRow, 1), .Cells(newRow + y, 2))
'Copy column header
.Range(.Cells(newRow, 3), .Cells(newRow + (y - 2), 3)) = Cells(1, i)
'Copy column values
Range(Cells(2, i), Cells(y, i)).Copy .Range(.Cells(newRow, 4), .Cells(newRow + y, 4))
End With
Next
End Sub
If your demands vary, such as adding other "fixed" columns like ID and Color then you'll have to change the cell addressing and such.
These two method will transpose the data much faster than Range.Copy and Range.Paste.
PivotTableValues - dumps the Range.Value into an array, data, then fills a second array, results, with the transposed values. Note: Transposed in this context simply means moved to a different place.
PivotTableValues2 - uses Arraylists to accomplish the OP's goals. Although it works great, it is somewhat a farcical answer. I just wanted to try this approach for esoteric reasons.
PivotTableValues Using Arrays
Sub PivotTableValues()
Const FIXED_COLUMN_COUNT As Long = 2
Dim ArrayRowCount As Long, Count As Long, ColumnCount As Long, RowCount As Long, x As Long, y As Long, y2 As Long
Dim data As Variant, results As Variant, v As Variant
With ThisWorkbook.Worksheets("Sheet1")
RowCount = .Range("A" & .Rows.Count).End(xlUp).Row
ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
data = Range(.Range("A" & .Rows.Count).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft)).Value
ArrayRowCount = (ColumnCount - FIXED_COLUMN_COUNT) * (RowCount - 1) + 1
ReDim results(1 To ArrayRowCount, 1 To FIXED_COLUMN_COUNT + 2)
Count = 1
For y = FIXED_COLUMN_COUNT + 1 To ColumnCount
For x = 2 To RowCount
Count = Count + 1
results(Count, FIXED_COLUMN_COUNT + 1) = data(1, y)
results(Count, FIXED_COLUMN_COUNT + 2) = data(x, y)
For y2 = 1 To FIXED_COLUMN_COUNT
If Count = 2 Then
results(1, y2) = data(1, y2)
results(1, y2 + 1) = "Category"
results(1, y2 + 2) = "Value"
End If
results(Count, y2) = data(x, y2)
Next
Next
Next
End With
With ThisWorkbook.Worksheets.Add
.Range("A1").Resize(UBound(results), UBound(results, 2)).Value = results
.Columns.AutoFit
End With
End Sub
PivotTableValues2 Using ArrayLists
Sub PivotTableValues2()
Const FIXED_COLUMN_COUNT As Long = 2
Dim ColumnCount As Long, RowCount As Long, x As Long, y As Long
Dim valueList As Object, baseList As Object, results As Variant, v As Variant
Set valueList = CreateObject("System.Collections.ArrayList")
Set baseList = CreateObject("System.Collections.ArrayList")
With ThisWorkbook.Worksheets("Sheet1")
RowCount = .Range("A" & .Rows.Count).End(xlUp).Row
ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
For x = 1 To RowCount
baseList.Add Application.Transpose(Application.Transpose(Range(.Cells(x, 1), .Cells(x, FIXED_COLUMN_COUNT))))
Next
For y = FIXED_COLUMN_COUNT + 2 To ColumnCount
baseList.AddRange baseList.getRange(1, RowCount - 1)
Next
For y = FIXED_COLUMN_COUNT + 1 To ColumnCount
For x = 2 To RowCount
valueList.Add Array(.Cells(1, y).Value, .Cells(x, y).Value)
Next
Next
End With
results = Application.Transpose(Application.Transpose(baseList.ToArray))
With ThisWorkbook.Worksheets.Add
.Range("A1").Resize(UBound(results), UBound(results, 2)).Value = results
valueList.Insert 0, Array("Category", "Value")
results = Application.Transpose(Application.Transpose(valueList.ToArray))
.Cells(1, FIXED_COLUMN_COUNT + 1).Resize(UBound(results), UBound(results, 2)).Value = results
.Columns.AutoFit
End With
End Sub
I am trying to loop the value for column E so that I can use it to VLookup on another worksheet and return the value to column F.
It has been giving me the error
of Application-defined or object-defined error
on the line:
result = Application.WorksheetFunction.VLookup(look, Sheet2.Range("B:H"), 2,
False)
My Code
Dim X As Integer
Dim look As Variant
Dim result As Variant
X = 2
Sheet3.Range("E2").Select
Do Until IsEmpty(ActiveCell)
look = Sheet3.Cells(X, 5).Value
ActiveCell.Offset(1, 0).Select
result = Application.WorksheetFunction.VLookup(look, Sheet2.Range("B:H"), 2, False)
Sheet3.Cells(X, 6).Value = result
X = X + 1
Loop
Try the code below (without using Select, and ActiveCell) :
Option Explicit
Sub VLookupHandleNA()
Dim X As Long
Dim Look As Variant
Dim Result As Variant
X = 2
With Sheet3
Do Until IsEmpty(.Range("E" & X).Value)
Look = .Range("E" & X).Value
Result = Application.VLookup(Look, Sheet2.Range("B:H"), 2, False)
If Not IsError(Result) Then
.Range("F" & X).Value = Result
Else ' if Vlookup returns an error, just write something in the cell to let the user know
.Range("F" & X).Value = "VLookup wasn't able to find " & Look
End If
X = X + 1
Loop
End With
End Sub