Updated:
Taking into consideration community comments, I have made some changes (declarations, removed unnecessary variables) and attempted two styles to no avail.
Without criteria the code returns 400, after one line is populated.
.Cells(i, 38 + l) = Evaluate("=SUMPRODUCT(" & Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn & "," & Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn & ",--(" & Worksheets(Cells(i, 1).Value).Columns(4).EntireColumn & "=" & .Cells(i, 2).Value & "),--(" & Worksheets(Cells(i, 1).Value).Columns(5).EntireColumn & "=" & .Cells(i, 3).Value & "))")
And also:
.Cells(i, 38 + l) = Application.WorksheetFunction.SumProduct(Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn, Worksheets(Cells(i, 1).Value).Columns(83 + l * 4).EntireColumn, --(Worksheets(Cells(i, 1).Value).Columns(4).EntireColumn = .Cells(i, 2).Value), --(Worksheets(Cells(i, 1).Value).Columns(5).EntireColumn = .Cells(i, 3).Value))
/Update end.
I have been trying to code a macro, which will gather data from different worksheets of one workbook to summary sheet and perform necessary calculations ("sumifs", "sumproduct") in cycle. The same code will be used in the other workbooks with different variable parameters.
While "sumifs" is working fine, there is an issue with "sumproduct" function (I am using Application.WorksheetFunction instead of Evaluate).
The code returns Type Mismatch error. Most likely I am calling the function improperly, OR, the criteria within the function.
I am kindly asking for community support, as I feel, I have exhausted my ability to think today.
' Populate table from KA sheets for I/O to SOP Report
Dim EndRow As Long
Dim i As Long
Dim j As Long
Dim l As Long
Dim catLst As Range
Dim pglst As Range
Start:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
EndRow = Cells(Rows.Count, 1).End(xlUp).Row
Set pglst = ThisWorkbook.Worksheets("SUMMARY").Range("$D:$D")
Set catLst = ThisWorkbook.Worksheets("SUMMARY").Range("$E:$E")
For i = 4 To EndRow
For j = 0 To 24
For l = 0 To 6
With ThisWorkbook.Worksheets("IO")
.Cells(i, 4 + j) = Application.WorksheetFunction.SumIfs(Worksheets(Cells(i, 1).Value).Columns(54 + j).EntireColumn, pglst, .Cells(i, 2).Value, catLst, .Cells(i, 3).Value)
.Cells(i, 30 + l) = Application.WorksheetFunction.SumIfs(Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn, pglst, .Cells(i, 2).Value, catLst, .Cells(i, 3).Value)
.Cells(i, 38 + l) = Application.WorksheetFunction.SumProduct(Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn, Worksheets(Cells(i, 1).Value).Columns(83 + l * 4).EntireColumn, --(Worksheets(Cells(i, 1).Value).Columns(4).EntireColumn = .Cells(i, 2).Value), --(Worksheets(Cells(i, 1).Value).Columns(5).EntireColumn = .Cells(i, 3).Value))
' .Cells(i, 38 + l) = Evaluate("=SUMPRODUCT(" & Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn & "," & Worksheets(Cells(i, 1).Value).Columns(81 + l * 4).EntireColumn & ",--(" & Worksheets(Cells(i, 1).Value).Columns(4).EntireColumn & "=" & .Cells(i, 2).Value & "),--(" & Worksheets(Cells(i, 1).Value).Columns(5).EntireColumn & "=" & .Cells(i, 3).Value & "))")
End With
Next l
Next j
Next i
'Set i = Nothing
'Set j = Nothing
'Set l = Nothing
ThisWorkbook.Worksheets("IO").Range("AS1") = "UPDATED: " & Format(Now(), "dd/mm/yyyy HH:MM")
Finish:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
First thing:
Dim catLst, pglst, condPG, condCAT As Range
only condCAT is declared as Range the rest is declared as Variant.
(Same with your long declaration)
Like BigBen wrote, it is unclear what you are doing with this evaluate.
You should not use Evaluate
Set for every part in your SumProduct a range. So that your Sumproduct would be like
Application.WorksheetFunction.SumProduct(range1,range2,...)
And look, if every range has the same size. SumProduct is a matrix function.
E.G. Range("A1:A5") Range("B1:B3") could not work in Sumproduct because of Elements
But I guess, some parts of your SumProduct are just wrong type.
Related
1) Write a statement in excel that will insert rows and fill missing data for days missing any hour. Hours in “DATE_HR” should go from 00-23 (24 hour time).
And
2) For hours that are listed, under “DATE_HR” (DD-MMM-YYYY-HH), that are missing “0” (which is NDG in “Class”) “1-4”, “GR”, and/or “SB” in “CLASSIFICATION”, for any given hour, write a statement that will insert and fill missing rows in all hours that has the missing “CLASSIFICATION”, “Class”, “DATE_HR”, AND “Total” (which missing “TOTAL” row values should be zero since there was no entry for the missing data).
Below is an example of what the program needs to do. The left is the missing data table (before) and the right is the corrected table (after), Yellow is 1 and blue is 2
-Here is my progress up to now:
I have written pseudo code for the issue and have started writing at in excel VBA. Here is the pseudo code:
SR = Selected_row
RA = Row_above
C = Classification
DT = Date & Time
IR=Insert_row
# = Any number 1-4
Start on seleted row
Loop statement:
= IF(SRC = ”GR” AND RAC = 4 AND SRDT== RADT, SR,
OR(SRC = ”SB” AND RAC = “GR” AND SRDT== RADT, SR,
OR(SRC = 0 AND RAC = “SB” AND SRDT== RADT -1day/+22hour, SR,
OR(SRC = # AND RAC = SRC -1 AND SRDT == RADT, SR,
OR(SRC = 0 AND RADT = -1day of SRC/23hour, SRC = “0” AND SRDT= RADT +1day/00hour,IR AND
IF(RAC = ”SB” AND RADT = 23hour, SRC = “0” AND SRDT= RADT +1day/00hour,
OR (RAC = ”SB”, SRC = “0” AND SRDT= RADT +1hour,
OR (RAC = ”GR”, SRC = “SB” AND SRDT= RADT,
OR (RAC = 4, SRC = “GR” AND SRDT= RADT,
OR(RAC = # AND SRC = RAC +1 AND SRDT == RADT, SR *here # = 0-3
)))))))))))))
Move onto next row below previous row
IF(SR=””, END program, continue)
Here is the excel VBA code: (the colors are just it see if it’s doing what it should)
Sub IF_Loop()
Dim i As Long
For i = 2 To 155
If (Range("B" & i).Value = "GR" And Range("B" & i - 1).Value = 4 And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "SB" And Range("B" & i - 1).Value = "GR" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "4" And Range("B" & i - 1).Value = "3" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "3" And Range("B" & i - 1).Value = "2" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "2" And Range("B" & i - 1).Value = "1" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "1" And Range("B" & i - 1).Value = "00" And Range("C" & i).Value = Range("C" & i - 1).Value) Then
Rows(i & ":" & i).Interior.Color = 9359529
Else
'insert row and correct data
Rows(i & ":" & i).EntireRow.Insert shift:=x1Down And _
Rows(i & ":" & i)
End If
Next i
I’m not sure how to write the remaining code. How do you properly write the remaining lines so the code will execute the tasks that are needed?
I would do this differently.
You need to know your starting and ending dates, and you also need to have a list of ALL of the Classifications and the associated Classes. (I hard coded both within the macro, but you can use other schemes).
From that you can create a table with all of the classes and all of the hours for all of the dates.
Once you've done that, you can look up to see if the Totals are available for the classification/date combination, and either write that in, or, if not present, a zero.
I used a class object which contains the information. Each of these objects has a collection (dictionary) of all the date_hr | total combinations available for that classification, and also a method to return the class for a given classification.
Working with VBA arrays is orders of magnitude faster than multiple read/writes to/from worksheets.
I hopefully have commented the code enough so you can understand what is going on.
For an excellent discussion of class objects, see the late Chip Pearsons Introduction to Classes. If this link dies, you'll need to do a web search. There is also an article there on reading/writing arrays to/from worksheet ranges which you will find useful.
Read the comments, especially at the beginning of each module, carefully so as to properly set things up, otherwise, it won't run.
It does assume that your data has a header row, and starts in A1.
The results are placed on the same worksheet, but it should be obvious how to change that.
Class Module
'**Rename this module: cClass**
Option Explicit
Private pClass As String
Private pClassification As String
Private pDate_HR As Date
Private pDate_HRs As Dictionary
Public Property Get class() As String
Select Case Me.Classification
Case "1"
class = "Freshman"
Case "2"
class = "Sophomore"
Case "3"
class = "Junior"
Case "4"
class = "Senior"
Case "GR"
class = "Graduate"
Case "SB"
class = "Second Bachelor"
Case "0"
class = "NDG"
Case Else
class = "N/A"
End Select
End Property
Public Property Get Classification() As String
Classification = pClassification
End Property
Public Property Let Classification(Value As String)
pClassification = Value
End Property
Public Property Get Date_HR() As Date
Date_HR = pDate_HR
End Property
Public Property Let Date_HR(Value As Date)
pDate_HR = Value
End Property
Public Property Get Date_HRs() As Dictionary
Set Date_HRs = pDate_HRs
End Property
Public Function addDate_HRsItem(dtHR As Date, toTAL As Long)
Date_HRs.Add Key:=dtHR, Item:=toTAL
End Function
Private Sub Class_Initialize()
Set pDate_HRs = New Dictionary
pDate_HRs.CompareMode = TextCompare
End Sub
Regular Module
Option Explicit
'set reference to microsoft scripting runtime
Sub fillData()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim I As Long, J As Long
Dim dD As Dictionary, cc As cClass
Dim sKey As String, sDTkey As Date
'set source and results worksheets, range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 7)
'read source data into vba array
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
'Process the known data
'collect it into a dictionary for fast lookups
Set dD = New Dictionary
dD.CompareMode = TextCompare
For I = 2 To UBound(vSrc, 1)
Set cc = New cClass
With cc
.Classification = vSrc(I, 1)
.Date_HR = convDTHR(vSrc(I, 3))
.addDate_HRsItem .Date_HR, CLng(vSrc(I, 4))
sKey = .class
If Not dD.Exists(sKey) Then
dD.Add sKey, cc
Else
dD(sKey).addDate_HRsItem .Date_HR, CLng(vSrc(I, 4))
End If
End With
Next I
'Create Results Array
'Unclear from your question how many dates you want, so will
' just do Mar 4
Const dtStart As Date = #3/4/2019#
Const dtEnd As Date = #3/5/2019#
'code the list of all Classifications
Dim arrClass
arrClass = Array(0, 1, 2, 3, 4, "GR", "SB")
ReDim vRes(0 To (dtEnd - dtStart + 1) * 24 * (UBound(arrClass) + 1), 1 To 4)
'write the column Headers into a results array
For J = 1 To 4
vRes(0, J) = vSrc(1, J)
Next J
'fill in other columns
For I = 1 To UBound(vRes, 1) Step UBound(arrClass) + 1
For J = 0 To UBound(arrClass)
vRes(I + J, 1) = arrClass(J) 'Classification
vRes(I + J, 2) = convCLASS(arrClass(J)) 'class
vRes(I + J, 3) = Format(dtStart + Int((I + J - 1) / (UBound(arrClass) + 1)) / 24, "dd-mmm-yyyy hh") 'The Date_hr
sKey = vRes(I + J, 2) 'key into dictionary
If dD.Exists(sKey) Then
sDTkey = convDTHR(vRes(I + J, 3)) 'key into collection of date/totals within the dictionary item
If dD(sKey).Date_HRs.Exists(sDTkey) Then
vRes(I + J, 4) = dD(sKey).Date_HRs(sDTkey)
Else
vRes(I + J, 4) = 0
End If
Else
vRes(I + J, 4) = 0
End If
Next J
Next I
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.Columns(1).HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End Sub
Private Function convDTHR(strDTHR) As Date
convDTHR = CDate(Left(strDTHR, 11)) + Right(strDTHR, 2) / 24
End Function
Private Function convCLASS(strClassification) As String
Dim cc As cClass
Set cc = New cClass
With cc
.Classification = strClassification
convCLASS = .class
End With
End Function
I've been getting a "method range of object _global failed" message when trying to use a combination of range objects and strings. I'm trying to iterate through several worksheets, copy and transpose each row from the worksheet, stack the transposed rows into a single column, then move to the next sheet to grab its rows and paste them to the next column over.
Dim CopyRng, pasteRng, Outnum, compsht As String
Dim myRng, PstRng As Range
For j = 5 To 10
For i = 1 To tot_centers
Outnum = "out" & j
CopyRng = "ThisWorkbook.Sheets(""" & Outnum & """).Cells(" & i & ", 2),
ThisWorkbook.Sheets(""" & Outnum & """).Cells(" & i & ", " & tot_days + 2 & ")"
Set myRng = Range(CopyRng)
Sheets(Outnum).Range(myRng).Copy 'THIS IS WHERE DEBUG HITS ERROR
pasteRng = "ThisWorkbook.Sheets(""" & "Compiled Data" & """).Cells(" & ((tot_days * (i - 1)) + (i + 1)) & ", " & j - 2 & ")"
Set PstRng = Range(pasteRng) 'AND I'LL PROBABLY GET THE SAME ERROR HERE
PstRng.PasteSpecial Transpose:=True
Next i
Next j
Something like this (tot_days/tot_centers variable names need resolving)
Dim CopyRng, pasteRng, Outnum, compsht As String
Dim myRng, PstRng As Range, j, i
Dim shtOut As Worksheet
For j = 5 To 10
Set shtOut = ThisWorkbook.Sheets("out" & j)
For i = 1 To tot_centers '<< tot_days ?
shtOut.Cells(i, 2).Resize(1, tot_days + 1).Copy '<< tot_centers?
ThisWorkbook.Sheets("Compiled Data").Cells(tot_days * (i - 1) + (i + 1), _
j - 2).PasteSpecial Transpose:=True
Next i
Next j
For anybody who sees this post and wants to know how to open sheets, grab multiple rows one at a time, and stack them into individual columns, here's how the code turned out:
Dim Outnum As String
For j = 5 To 10 'use worksheets with outputs 5 through 10
For i = 1 To tot_centers 'in this case, tot_centers was declared earlier in the code and is and integer I count from a sheet
Outnum = "out" & j
Sheets(Outnum).Range(Sheets(Outnum).Cells(i, 2), Sheets(Outnum).Cells(i, tot_days + 2)).Copy
Sheets("Compiled Data").Range(Sheets("Compiled Data").Cells((tot_days * (i - 1)) + (i + 1), j - 1), Sheets("Compiled Data").Cells((tot_days * (i - 1)) + (i + 1), j - 1)).PasteSpecial Transpose:=True
Next i
Next j
End Sub
I have a code that takes a list of Airline flightlegs and matches them up to give me full lines of flight. The code works but..... it takes a very long time (45-60 min for just 35,000 rows) due to the amount of data it has to go through. This is compounded and the overall code takes about 2 hours to run. Is there a faster method to get the same results?
Here is my current code that really bogs down the entire process:
Sub BuildingLines()
'strings together segments into trip
Dim i As Long
Dim z As Long
Dim T As Long
Dim c As Long
Dim a As Long
Dim f As Long
Dim l As Long
Dim g As Long
Dim y As String
Dim b As String
Set ref = Sheets("Ref")
With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row
For a = 24 To g
If ref.Cells(a, 2) = "" Then GoTo nexta
f = ref.Cells(a, 2)
c = ref.Cells(a, 3)
l = ref.Cells(a, 4)
Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
For i = f To l
Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
DoEvents
'On Error GoTo NextI
If IsError(Application.Match(.Cells(i, 2), LegTable, 0)) Then
GoTo nexti
Else
y = Application.Match(.Cells(i, 2), LegTable, 0) + f - 1
.Cells(i, 1).End(xlToRight).Offset(0, 1).Value2 = .Cells(y, 2)
Do
'On Error GoTo NextI
If IsError(Application.Match(.Cells(y, 2), LegTable, 0)) Then
GoTo nexti
Else
b = Application.Match(.Cells(y, 2), LegTable, 0) + f - 1
h = .Cells(b, 2)
.Cells(i, 1).End(xlToRight).Offset(0, 1) = h
y = b
End If
Loop
nexti:
End If
b = ""
y = ""
Next i
nexta:
Next a
End With
End Sub
The data is all string data of about 50+ chars.
Thank you for any recomendations.
Thank you very much A.S.H. with your help, I not only learned alot about using arrays, but also ended up cutting my runtime from about 90 minutes to just over 3 minutes. This is my final working code that used a combination of your suggestions.
Sub BuildingLines()
'strings together segments into trip
Dim i As Long
Dim z As Long
Dim c As Long
Dim f As Long
Dim l As Long
Dim LegTable As Range
Dim TurnTable As Range
Dim FirstTurn() As Variant
Dim NextTurn() As Variant
Dim y As String
Dim b As String
Dim FTtext As String
Dim wb As Workbook
Dim ref As Worksheet
Set wb = ThisWorkbook
Set ref = wb.Sheets("Ref")
With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row
For a = 24 To g
If ref.Cells(a, 2) = "" Then GoTo NextA
f = ref.Cells(a, 2)
c = ref.Cells(a, 3)
l = ref.Cells(a, 4)
Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
Set TurnTable = Range(.Cells(f, 1), .Cells(l, 2))
FirstTurn = TurnTable
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=LegTable, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange TurnTable
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = f To l
Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
DoEvents
y = 0
b = 0
y = Application.Match(.Cells(i, 2), LegTable, 1)
If .Cells(i, 2) <> FirstTurn(y, 1) Then GoTo NextI
NextLeg = NextLeg + 1
ReDim Preserve NextTurn(0, 1 To NextLeg)
NextTurn(0, NextLeg) = FirstTurn(y, 2)
Do
FTtext = FirstTurn(y, 2)
On Error GoTo errhdlr
b = Application.WorksheetFunction.Match(FTtext, LegTable, 1)
If FTtext <> FirstTurn(b, 1) Then GoTo NextI
NextLeg = NextLeg + 1
ReDim Preserve NextTurn(0, 1 To NextLeg)
NextTurn(0, NextLeg) = FirstTurn(b, 2)
y = b
Loop
errhdlr:
Resume NextI
NextI:
If NextLeg > 0 Then Range(.Cells(i, 3), .Cells(i, NextLeg + 2)).Value = NextTurn
Erase NextTurn
NextLeg = 0
Next i
Set LegTable = Nothing
Set TurnTable = Nothing
Erase NextTurn
Erase FirstTurn
NextA:
Next a
End With
End Sub
I first tried using just the arrays, but the Match function was WAY SLOWER in the arrays. So I ended up using the Match to find the index and then grabbed the data from the array to build my second array which then became my output. I can't wait to adapt my new found knowledge with the rest of this project and cut my runtime from 2+ hours to just minutes!! Thanks, again!!!
I have a big table in excel, which contains about 8000 rows of data. I am working on a procedure to enable the users to receive a pdf copy of what they are looking for. (A detail list related to a work order).
I tried two different approaches, first copying the work order items after filtering it to a third sheet and then copying selected fields of data to the final form. It was good and fast.
second, after filter directly copying data of unhidden rows to the final form. (also more sort and remove duplicated items happen too)
The second one is very time killing (3 to 5 minutes) and very heavy.
Now, I am thinking of first sorting the data in a way that my desired item (what the user is looking for) comes to the first of table so after the filter, I just ask the loop to go until a visible number of rows, not until the end of rows.
Has anyone any idea, or better solution?
Cheers and merry Christmas!
Sub kit_Click()
' On Error GoTo Errorhandler
Dim wc As String
Dim c As Integer
Dim tbl As Range
Dim sel As Range
Dim des As Range
Dim m As Integer
Dim j As Integer
Dim aggrow As Integer
Dim varResult As Variant
Dim kf As Worksheet
Set kf = Worksheets("Kit Form")
a = ""
' Application.ScreenUpdating = False
' finding W/B code to prepare
If Not Intersect(ActiveCell, Range("d2:d3")) Is Nothing Then
a = Cells(2, 7).Value
GoTo body
ElseIf ActiveCell.Row < 6 Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
ElseIf ActiveCell.Row > ActiveSheet.UsedRange.Rows.Count Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else: a = Cells(ActiveCell.Row, 2).Value
End If
body:
On Error GoTo skip
wc = WorksheetFunction.VLookup(a, Range("b5:c1000"), 2, 0)
skip:
If a = "" Or a = "0" Then
a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else
' Cleaning KIT FORM
If Not kf.ListObjects("KitForm").DataBodyRange Is Nothing Then kf.ListObjects("KitForm").DataBodyRange.EntireRow.Delete
' Filtering the W/B Kittable items
With Sheets("FTV3")
.Range("tbl").AutoFilter Field:=3, Criteria1:="*" & a & "*", Operator:=xlFilterValues
.Range("tbl").AutoFilter Field:=25, Criteria1:="OK", Operator:=xlFilterValues
' Unhidding the Columns and copying the header row
.Cells.EntireColumn.Hidden = False
' Copying the data to Form
lstrw = .Cells(Rows.Count, 8).End(xlUp).Row
kf.Cells(2, 2) = a
kf.Cells(1, 4) = wc
m = 1
For i = 2 To lstrw
If .Rows(i).EntireRow.Hidden Then
m = m + 1
Else
kf.Rows(i - m + 4).RowHeight = 25
kf.Cells(i - m + 4, 1).Value = i - m
If .Cells(i, 21).Value = "_N/A" Then
kf.Cells(i - m + 4, 2) = "'"
Else
kf.Cells(i - m + 4, 2) = .Cells(i, 21)
End If
kf.Cells(i - m + 4, 3).Value = .Cells(i, 4).Value
If .Cells(i, 4).Value <> "_Book" Then kf.Cells(i - m + 4, 4).Value = .Cells(i, 26).Value
Worksheets("Kit Form").Cells(i - m + 4, 5).Value = .Cells(i, 7).Value
If .Cells(i, 8).Value <> "N/T" Then kf.Cells(i - m + 4, 6).Value = .Cells(i, 8).Value
If .Cells(i, 12).Value <> "_N/A" Then ttt = .Cells(i, 12) 'Or .Cells(i, 22).Value <> ""
kf.Cells(i - m + 4, 7).Value = "(( " & .Cells(i, 27).Value & " ))" & Chr(10) & ttt
kf.Rows(i - m + 4).AutoFit
If kf.Rows(i - m + 4).RowHeight < 25 Then kf.Rows(i - m + 4).RowHeight = 25
End If
Next
.Range("A:B,S:ac").EntireColumn.Hidden = True
aggrow = kf.Cells(Rows.Count, 1).End(xlUp).Row - 4
.Range("tbl").AutoFilter
End With
Call remove_duplicate
R = MsgBox("Successfuly Total of " & lstrw - m - 1 & " Items, aggregated in " & aggrow & " Rows of material Copied to the Kit Form " & Chr(10) & Chr(10) & "Do you want an PDF version of The form being prepared for you?", vbYesNo, "Result")
If R = 6 Then Call export_pdf
End If
End Sub
I need to compare 2 cells in different sheets and get a value if there's a match. I currently have this piece of code, it each cell in column B is checked to each cell in column A and if there's a match the corresponding cell in column C is copied. So far so good, the problem is, it takes a long time to do so. I only have 750 records in column B and 4000 in column A.
Are there ways to optimize the code so it runs faster?
For i = 2 To LastRow
For j = 2 To LastRowJ
If Sheets("tempsheet").Range("B" & i).Value = Sheets("tempsheet").Range("A" & j).Value Then
Range("Q" & i).Value = Sheets("tempsheet").Range("C" & j).Value
End If
Next j
Next i
Here are 6 measurements:
1. copyValsCell1(): 90.78125 sec (posted code)
2. copyValsCell2(): 53.27343 sec (ws object)
3. copyValsCell3(): 52.67187 sec (With statement, and screen off)
4. copyValsArr(): 0.60937 sec (Array - no restrictions)
5. copyValsDictCell(): 0.07812 sec (Dictionary with Range - unique values only)
6. copyValsDictArr(): 0.03125 sec (Dictionary with Array - unique values only)
In my test file I had all values on the same sheet (lr = 4000: lrj = 750)
.
Initial code - Duration copyValsCell1(): 90.78125 sec
ws object
Set ws = Sheets("tempsheet")
For i = 2 To lr 'Duration copyValsCell2(): 53.2734375 sec
For j = 2 To lrj
If ws.Range("B" & i).Value = ws.Range("A" & j).Value Then
ws.Range("Q" & i).Value = ws.Range("C" & j).Value
End If
Next
Next
With statement, and screen off
Set ws = Sheets("tempsheet")
Application.ScreenUpdating = False
For i = 2 To lr 'Duration copyValsCell3(): 52.671875 sec
For j = 2 To lrj
With ws
If .Range("B" & i).Value2 = .Range("A" & j).Value2 Then
.Range("Q" & i).Value2 = .Range("C" & j).Value2
End If
End With
Next
Next
Application.ScreenUpdating = True
Array
Dim v As Variant
v = Sheets("tempsheet").Range("A1:Q4000")
For i = 2 To lr 'Duration copyValsArr(): 0.609375 sec
For j = 2 To lrj
If v(i, 2) = v(j, 1) Then v(i, 17) = v(j, 3)
Next
Next
Sheets("tempsheet").Range("A1:Q4000") = v
Dictionary with Range (requires reference to Microsoft Scripting Runtime library)
Set d = New Dictionary: Set ws = Sheets("tempsheet")
For i = 2 To lrj 'Duration copyValsDictCell(): 0.078125 sec
d(ws.Range("A" & i).Value2) = i
Next
For i = 2 To lr
If d.Exists(ws.Range("B" & i).Value) Then
ws.Range("Q" & i).Value = ws.Range("C" & d(ws.Range("B" & i).Value)).Value
End If
Next
Dictionary with Array (requires reference to Microsoft Scripting Runtime library)
Dim v As Variant
v = Sheets("tempsheet").Range("A1:Q4000")
Set d = New Dictionary 'Duration copyValsDictArr(): 0.03125 sec
For i = 2 To lrj
d(v(i, 1)) = i
Next
For i = 2 To lr
If d.Exists(v(i, 2)) Then v(i, 17) = v(d(v(i, 2)), 3)
Next
Sheets("tempsheet").Range("A1:Q4000") = v
Try this:
For i = 2 To LastRow
Set match_check = Sheets("tempsheet").Range("A:A").Find(Sheets("tempsheet").Range("B" & i), Lookat:=xlWhole)
If Not match_check Is Nothing Then Range("Q" & i) = match_check.Offset(0,2)
Next i
Find returns a Range object of the first found match in the column and Nothing if no match is found. I didn't check the run time but it should be faster than the double for loop.
You could use a dictionary keyed to the values in Column A -- assuming that these values are all distinct (otherwise your code itself doesn't quite make sense. Include a reference to Microsoft Scripting Runtime (via Tools/References in the VBA editor). The following code should be over 100 times as fast as what you currently have:
Sub test()
Dim LastRow As Long, LastRowJ As Long
Dim i As Long, j As Long
Dim AVals As New Dictionary
LastRow = Sheets("tempsheet").Cells(Rows.Count, "B").End(xlUp).Row()
LastRowJ = Sheets("tempsheet").Cells(Rows.Count, "A").End(xlUp).Row()
For j = 2 To LastRowJ
AVals.Add Sheets("tempsheet").Range("A" & j).Value, j
Next j
For i = 2 To LastRow
If AVals.Exists(Sheets("tempsheet").Range("B" & i).Value) Then
j = AVals(Sheets("tempsheet").Range("B" & i).Value)
Range("Q" & i).Value = Sheets("tempsheet").Range("C" & j).Value
End If
Next i
End Sub