I am basically creating a VBA script to clean out a report sheet. I have everything downpacked but cannot figure out how to make VLOOKUP work to check on multiple workbooks. I basically have to match serial numbers on the report to serial numbers located either on folder A or Folder B.
As of right now, I have manually set the Range().Value =VLOOKUP for only one workbook but If I do it for a second then it might create conflicts. However, I want to know if it's possible to VLOOKUP an entire column from the LastRow up and ignore blanks while checking both workbooks.
Sub LowTonerSOC()
Dim i As Long
For i = Cells(Rows.Count, "J").End(xlUp).Row To 2 Step -1
If Cells(i, "J") <> "Yes" Then Rows(i).Delete
Next i
For i = Cells(Rows.Count, "K").End(xlUp).Row To 2 Step -1
If Cells(i, "K") <> "Yes" Then Rows(i).Delete
Next i
For i = Cells(Rows.Count, "O").End(xlUp).Row To 2 Step -1
If Cells(i, "O") <> "Headquarters" And Cells(i, "O") <> "INDUSTRIAL" And Cells(i, "O") <> "VAUSA" Then Rows(i).Delete
Next i
Columns(1).EntireColumn.Delete
Columns(1).EntireColumn.Delete
Columns(1).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Columns(7).EntireColumn.Delete
Range("C:F" & LastRow).Replace "", "999", xlWhole
For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If Cells(i, "C").Value2 >= 10 And Cells(i, "D").Value2 >= 10 And Cells(i, "E").Value2 >= 10 And Cells(i, "F").Value2 >= 10 Then
Rows(i).Delete
End If
Next i
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
If Cells(i, "C").Value2 <= 10 Then
Cells(i, "C").Interior.ColorIndex = 15
End If
Next i
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D").Value2 <= 10 Then
Cells(i, "D").Interior.ColorIndex = 8
End If
Next i
For i = Cells(Rows.Count, "E").End(xlUp).Row To 2 Step -1
If Cells(i, "E").Value2 <= 10 Then
Cells(i, "E").Interior.ColorIndex = 3
End If
Next i
For i = Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
If Cells(i, "F").Value2 <= 10 Then
Cells(i, "F").Interior.ColorIndex = 6
End If
Next i
Application.Calculation = xlAutomatic
Range("C:F" & LastRow).Replace "999", "", xlWhole
ActiveSheet.Name = "Sheet1"
Range("G1").Value = "Physical Location"
Range("G2").Value = "=VLOOKUP(B2,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G3").Value = "=VLOOKUP(B3,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G4").Value = "=VLOOKUP(B4,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G5").Value = "=VLOOKUP(B5,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G6").Value = "=VLOOKUP(B6,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G7").Value = "=VLOOKUP(B7,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G8").Value = "=VLOOKUP(B8,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G9").Value = "=VLOOKUP(B9,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G10").Value = "=VLOOKUP(B10,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G11").Value = "=VLOOKUP(B11,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G12").Value = "=VLOOKUP(B12,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G13").Value = "=VLOOKUP(B13,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G14").Value = "=VLOOKUP(B14,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G15").Value = "=VLOOKUP(B15,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G16").Value = "=VLOOKUP(B16,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G17").Value = "=VLOOKUP(B17,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G18").Value = "=VLOOKUP(B18,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G19").Value = "=VLOOKUP(B19,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G20").Value = "=VLOOKUP(B20,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G21").Value = "=VLOOKUP(B21,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G22").Value = "=VLOOKUP(B22,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G23").Value = "=VLOOKUP(B23,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G24").Value = "=VLOOKUP(B24,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G25").Value = "=VLOOKUP(B25,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G26").Value = "=VLOOKUP(B26,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G27").Value = "=VLOOKUP(B27,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G28").Value = "=VLOOKUP(B28,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G29").Value = "=VLOOKUP(B29,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Range("G30").Value = "=VLOOKUP(B30,'\\spwsrf\Deskside\Desktop\EUS\AssestInventory\Printers\[Printers.xlsm]Sheet1'!$F$1:$G$230,2,0)"
Application.ScreenUpdating = False
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Pick column that has no blank in setting last row to vlookup in entire column
LastRow = WorksheetFunction.Max(Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row, 9)
then for vlookup that has multiple workbook, set your workbooks
Sub VlookMultipleWorkbooks()
Dim lookFor as String
Dim srchRange as Range
Dim book1 as Workbook
Dim book2 as Workbook
'Set some Workbook variables:
Set book1 = Workbooks("Book 1 Name") '<edit as needed
Set book2 = Workbooks("Book 2 Name") '<edit as needed
'Set a string variable that we will search for:
lookFor = book2.sheets(5).range(Cells(j, c + 1))
'Define the range to be searched in Book1.Sheets(4):
Set srchRange = book1.Sheets(4).Range(cells(row1+2,1).Address, cells(row2,col1).Address)
'This assumes that the Book2 is Open and you are on the desired active worksheet:
ActiveSheet.Cells(j, c + 2).value = _
Application.WorksheetFunction.VLookup(lookFor, _
book1.Sheets(4).Range(srchRange.Address), 3, False)
End Sub
refer to this link for vlookup with multiple vlookup Sub VlookupMultipleWorkbook
Related
I have a monthly report with 25K-30K lines from which I want to delete lines based on cell values. The report has a dynamic number of rows each month but the number of columns are fixed, from A to X. I am using the For Next Loop to search into the cells for the values that will trigger the deletion of rows, in the worksheet "Data" of the report. There is a second sheet in this report named "Public accounts" where the macro searches and adds a tag (public or private) into each of the rows in the "Data" sheet. It then checks several conditions (like if the values of the cells in columns R and S are equal then the line is deleted) using the For Next loop and if they are true the lines are deleted in the "Data" sheet of the report.
My problem is that it takes far too long to run (10-15 mins) in its condition. Can you please help me to speed it up? I am attaching the code that I am using.
Sub Format_Report()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Data").Activate
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("X2").Formula = "=if(isnumber(Match(A2,'Public accounts'!A:A,0)),""Public"",""Private"")"
Range("X2").AutoFill Destination:=Range("X2:X" & LR)
Last = Cells(Rows.Count, "A").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "R").Value) = (Cells(i, "S").Value) Then
Cells(i, "A").EntireRow.Delete
End If
Next i
For i = Last To 1 Step -1
If (Cells(i, "G").Value) = "ZRT" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
For i = Last To 1 Step -1
If (Cells(i, "G").Value) = "ZAF" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
For i = Last To 1 Step -1
If (Cells(i, "G").Value) = "E" Then
Cells(i, "A").EntireRow.Delete
End If
Next i
For i = Last To 1 Step -1
If Cells(i, 24) = "Public" Then
Cells(i, 24).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Please, test the next code. It should work very fast, using arrays, sort, delete at once, resort and clear the helper sort column:
Sub Format_Report()
Dim wsD As Worksheet, lastRD As Long, lastCol As Long
Dim arr, arrMark, arrSort, i As Long, boolFound As Boolean
Set wsD = ActiveSheet 'Worksheets("Data")
lastRD = wsD.Range("A" & wsD.rows.count).End(xlUp).row
lastCol = wsD.UsedRange.column + wsD.UsedRange.Columns.count + 1
arrSort = Evaluate("row(1:" & lastRD & ")") 'build an array to resort after deletion
wsD.Range("X2:X" & lastRD).Formula = "=if(isnumber(Match(A2,'Public accounts'!A:A,0)),""Public"",""Private"")"
wsD.Calculate
arr = wsD.Range("G1:X" & lastRD).Value2 'place the range in an array for faster iteration
ReDim arrMark(1 To UBound(arr), 1 To 1) 'reDim the array to keep deletion marks
For i = 1 To lastRD
If arr(i, 12) = arr(i, 13) And (arr(i, 12) <> "") Or _
arr(i, 1) = "ZRT" Or _
arr(i, 1) = "ZAF" Or _
arr(i, 1) = "E" Or _
arr(i, 18) = "Public" Then
arrMark(i, 1) = "Del": boolFound = True 'write in array an boolFound = true to confirm at least a row to be deleted
End If
Next i
Application.ScreenUpdating = False: Application.DisplayAlerts = False
wsD.cells(1, lastCol).Resize(UBound(arrMark), 1).Value2 = arrMark 'drop arrMark content at once:
wsD.cells(1, lastCol + 1).Resize(UBound(arrSort), 1).Value2 = arrSort
'sort the range based on arr column:
wsD.Range("A1", wsD.cells(lastRD, lastCol + 1)).Sort key1:=wsD.cells(1, lastCol), Order1:=xlAscending, Header:=xlNo ' sort the range by deletion column
With wsD.cells(1, lastCol).Resize(lastRD, 1)
If boolFound Then 'if at least a row to be deleted:
.SpecialCells(xlCellTypeConstants).EntireRow.Delete
End If
End With
'Resort the range based on arrSort column:
wsD.Range("A1", wsD.cells(lastRD, lastCol + 1)).Sort key1:=wsD.cells(1, lastCol), Order1:=xlAscending, Header:=xlNo
wsD.cells(lastRD, lastCol + 1).EntireColumn.ClearContents 'clear the column with the initial order
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox "Ready..."
End Sub
Objective of the code is to count the number of rows that meet three conditions and output the count to populate in a particular cell.
Input data:
The 3 conditions are:
Column A of the row must contain a date field
Column B of the row must be equal to "B"
Column A of the row must have red font
I have the following code, but it seems to not pick up the last condition properly. I am expecting to see 1 as an output but seeing 0:
Sub code()
Dim lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Cells(2, "D").Value = "Count"
Count = 0
For i = 2 To lrow
If IsDate(Cells(i, "A").Value) = True And Cells(i, "B").Value = "B" And Cells(i, "A").Font.Color = -16776961 Then
Count = Count + 1
End If
Next i
Cells(2, "E").Value = Count
End Sub
Sub test1()
Set cl = ActiveSheet.Range("A2")
Do Until IsEmpty(cl)
cnt = cnt - (IsDate(cl.Value) And cl.Offset(0, 1) = "B" And cl.Font.Color = vbRed)
Set cl = cl.Offset(1)
Loop
Debug.Print "Matches = " & cnt
End Sub
Input:
Output:
Matches = 2
Try this:
Dim lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Cells(2, "D").Value = "Count"
Count = 0
For i = 2 To lrow
If IsDate(Cells(i, "A").Value) = True And Cells(i, "B").Value = "B" And Cells(i, "A").Font.Color = vbRed Then
Count = Count + 1
End If
Next i
Cells(2, "E").Value = Count
You can achieve this using the color index as below:
.Font.ColorIndex = 3 which is red [enter link description here][1] They give more options and details on working with font colors.
Sub code()
Dim lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Cells(2, "D").Value = "Count"
Count = 0
For i = 2 To lrow
If IsDate(Cells(i, "A").Value) = True And Cells(i, "B").Value = "B" And Cells(i, "A").Font.ColorIndex = 3 Then
Count = Count + 1
End If
Next i
Cells(2, "E").Value = Count
End Sub
[1]: https://access-excel.tips/excel-vba-color-code-list/
Dim I As Long
For I = 2 To lastrow
If Not IsEmpty(Cells(I, "f")) And IsEmpty(Cells(I, "j")) Then
Cells(I, "j").Value = "unregister"
End If
Next I
Dim I2 As Long
For I2 = 2 To lastrow
If IsEmpty(Cells(I2, "f")) Then
Cells(I2, "i").Value = Cells(I2 - 1, "i").Value
End If
Next I2
can you make this code more simple i want to copy above row for 3 different column if column f is empty
You can do something like this, using a single loop and Offset(-1, 0) to get the cell above:
Dim i As Long, ws As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
With ws.Rows(i)
If Not IsEmpty(.Columns("F")) Then
If IsEmpty(.Columns("J")) Then .Columns("J").Value = "unregister"
Else
.Columns("I").Value = .Columns("I").Offset(-1, 0).Value
.Columns("L").Value = .Columns("L").Offset(-1, 0).Value
'etc
End If
End With
Next I2
I need to search in column B:B for a specific text, then if true paste other text to column L:L, exemple:
Sub teste()
Application.ScreenUpdating = False
last = Cells(Rows.Count, "B").End(xlUp).Row
For i = last To 1 Step -1
If (Cells(i, "B").Value) = "string_1" Then
Range("L2").Select
ActiveCell.FormulaR1C1 = "some_text_1"
'LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Range("L2").AutoFill Destination:=Range("L2:L" & LastRow)
End If
Next i
End Sub
I can only paste the first text if true or fill the column L:L with the same text.
You mean something like that?
If column B is string_1 then copy column C to column L
For i = last To 1 Step -1
If (Cells(i, "B").Value) = "string_1" Then
'copy value from C to L
Cells(i, "L").Value = Cells(i, "C").Value
End If
Next i
You might benefit from reading
How to avoid using Select in Excel VBA.
Sub teste()
Application.ScreenUpdating = False
s1 = "first_text"
s2 = "second_text"
s3 = "third_text"
last = Cells(Rows.Count, "B").End(xlUp).Row
For i = last To 1 Step -1
If (Cells(i, "B").Value) = "string_1" Then
Cells(i, "L").Value = s1
ElseIf (Cells(i, "B").Value) = "String_2" Then
Cells(i, "L").Value = s2
ElseIf (Cells(i, "B").Value) = "string_3" Then
Cells(i, "L").Value = s3
End If
Next i
End Sub
I'm trying to copy a range from one sheet to another, but ignoring blank rows, and making sure there aren't blank rows in the destination.
After looking on this site, I've successfully used the code below.
However, I want to expand this to a large data range and it seems to take an absolute age. Any ideas on a more efficient code? Slight newbie here!
Thanks!
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim Source As Worksheet
Dim Destination As Worksheet
Dim i As Integer
Dim j As Integer
Set Source = Sheet1
Set Destination = Sheet4
j = 2
For i = 9 To 10000
If Source.Cells(i, 2).Value <> "" Then
Destination.Cells(j, 1).Value = Source.Cells(i, 1).Value
Destination.Cells(j, 2).Value = Source.Cells(i, 2).Value
Destination.Cells(j, 3).Value = Source.Cells(i, 3).Value
Destination.Cells(j, 4).Value = Source.Cells(i, 4).Value
Destination.Cells(j, 5).Value = Source.Cells(i, 5).Value
Destination.Cells(j, 6).Value = Source.Cells(i, 6).Value
Destination.Cells(j, 7).Value = Source.Cells(i, 7).Value
Destination.Cells(j, 8).Value = Source.Cells(i, 8).Value
Destination.Cells(j, 9).Value = Source.Cells(i, 9).Value
j = j + 1
End If
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
End Sub
[Edited to add a bit of clarity]
Replace your for loop with codes below.
Method 1: union all the range you would like to copy, and paste them at once.
Dim copyRange As Range
For i = 9 To 10000
If Source.Cells(i, 2).Value <> "" Then
If copyRange Is Nothing Then
Set copyRange = Source.Range(Source.Cells(i, 1), Source.Cells(i, 9))
Else
Set copyRange = Union(copyRange, Source.Range(Source.Cells(i, 1), Source.Cells(i, 9)))
End If
End If
Next i
copyRange.Copy Destination.Cells(2, 1)
Method 2(recommended): Use an autofilter for filtering the data.
Dim sourceRng As Range
Set sourceRng = Source.Range(Source.Cells(9, 1), Source.Cells(10000, 9))
sourceRng.AutoFilter Field:=2, Criteria1:="<>"
sourceRng.Copy Destination.Cells(2, 1)
Source.AutoFilterMode = False
Looping through worksheet rows is almost the slowest way to process data blocks. The only thing slower is looping through both rows and columns.
I'm not sure how many records you have but this processed 1500 rows of dummy data in ~0.14 seconds.
Option Explicit
Sub Macro4()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim i As Long, j As Long, k As Long, arr As Variant
On Error GoTo safe_exit
appTGGL bTGGL:=False
Set wsSource = Sheet1
Set wsDestination = Sheet4
'collect values from Sheet1 into array
With wsSource
arr = .Range(.Cells(9, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 7)).Value
End With
'find first blank in column B
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, 2) = vbNullString Then Exit For
Next j
'collect A:I where B not blank
For i = j To UBound(arr, 1)
If arr(i, 2) <> vbNullString Then
For k = 1 To 9: arr(j, k) = arr(i, k): Next k
j = j + 1
End If
Next i
'clear remaining rows
For i = j To UBound(arr, 1)
For k = 1 To 9: arr(i, k) = vbNullString: Next k
Next i
'put values sans blanks into Sheet4
With wsDestination
.Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
safe_exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.EnableEvents = bTGGL
.ScreenUpdating = bTGGL
.DisplayAlerts = bTGGL
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End With
Debug.Print IIf(bTGGL, "end: ", "start: ") & Timer
End Sub