Related
I am trying to build a excel vba code that looks at data from three columns, takes the lowest 6 values of each variable (which there are four of) and also takes the adjacent column and pastes it in another sheet.
This is the input:
This is what I would like the output to be:
!
This is what the output actually is:
Actual Output
I stole a lot of this code from another post I saw, but it seems to be acting very randomly. I'm still not quite sure what the code is even doing, which is what makes it hard for me.
Any advice will help tremendously.
UPDATE: Using Ibo's fix on my sample data, it worked perfectly, however on my actual data it errored out. The reason I am doing this through a macro instead of manually is because it is a part of a much larger macro that is getting pieced together to predict production consumption of various raw materials and what needs to get staged.
Here's what happened:
Actual Input Data
Error 1004 Message and highlighted code
Output after failure
It looks like it got close, but didn't finish with the actual sort.
Sub TopPriorityPerPod()
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rngData As Range
Dim rngFound As Range
Dim rngUnqGroups As Range
Dim GroupCell As Range
Dim lCalc As XlCalculation
Dim aResults() As Variant
Dim aOriginal As Variant
Dim lNumTopEntries As Long
Dim i As Long, j As Long, k As Long
'Change to grab the top X number of entries per category'
lNumTopEntries = 6
Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output it'
Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
aOriginal = rngData.Value 'Store original values so you can set them back later'
'Turn off calculation, events, and screenupdating'
'This allows code to run faster and prevents "screen flickering"'
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
'On Error GoTo CleanExit
With rngData
'.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
.Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
End With
With rngData.Resize(, 1).Offset(, 1)
.AdvancedFilter xlFilterInPlace, , , True
Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.ShowAllData 'Remove the filter
ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
i = 0
For Each GroupCell In rngUnqGroups
Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
k = 0
If Not rngFound Is Nothing Then
For j = i + 1 To i + lNumTopEntries
If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
k = k + 1
aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
aResults(j, 2) = rngFound.Offset(j - i - 1).Value
aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
End If
Next j
i = i + k
End If
Next GroupCell
End With
'Output results'
wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
CleanExit:
'Turn calculation, events, and screenupdating back on'
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
'There was an error, show the error'
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
'Put data back the way it was
rngData.Value = aOriginal
End Sub
You can have different approaches. In this method I copy the data to another sheet called Result, then insert a table, sort the columns and then collect the range where the rows are more than 6 and then delete the whole rows at once, it will be really fast:
Sub Main()
Dim i As Long
Dim rng As Range
Dim tbl As ListObject
Dim WS As Worksheet
Dim WS2 As Worksheet
Set WS = Worksheets("Sheet1") 'this is where you have the data
Set WS2 = Worksheets.Add
WS2.Name = "Result"
WS.Range("A1").CurrentRegion.Copy
WS2.Paste
'sort priority column first
WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
Set tbl = WS2.ListObjects("Table1")
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort station column
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove any row exceeding 6th occurrence
Dim cnt As Integer
For i = 1 To tbl.ListRows.Count - 1
If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
cnt = cnt + 1
If cnt >= 6 Then
If rng Is Nothing Then
Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
Else
Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
End If
End If
Else
cnt = 0 'reset the counter
End If
Next i
'remove rows
If Not rng Is Nothing Then
tbl.Unlist
rng.EntireRow.Delete
End If
End Sub
So I've put something together for you that should get you most of the way there.
You'll need to do a few things to get this working for your file (learning opportunity!):
(1) Adjust the ranges as relevant to your file
(2) Print the output to the worksheet. As of right now the output is being printed to the immediate debug window.
What this code will do is sort out each letters values into a collection named after the letters.
From there we convert the collection to an array. We then utilize the "Small" worksheet function on the arrays, and loop through the 6 lowest values.
Happy to help with any further questions you may have!
Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.Count - 1)
For cnt = 0 To myCol.Count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
Sub ArraySort()
Dim Cell As Range
Dim KeyMultiple As String
Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection
Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")
Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")
Counter = 0
For i = 1 To 22
If Cells(i, 1).Value = "A" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "B" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "C" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "D" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
End If
Next i
For i = 1 To 6
Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i
Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection
End Sub
here's a solution exploiting Array, Dictionary and SortedList object, that shuold be quite fast:
Option Explicit
Sub main()
Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output
Dim stations As Variant, station As Variant
Dim iStation As Long
Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values
With wsData
stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
For iStation = 1 To UBound(stations, 1)
stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
Next
End With
Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
Dim iPriority As Long, nPriorities As Long
For Each station In stationsList.Keys ' loop through unique stations
prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list
With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
priority = Split(priorityAndOrder, "|")(0) ' get current priority
order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
.Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
Next
nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
results(iPriority + 1, 1) = station
results(iPriority + 1, 2) = .GetKey(iPriority)
results(iPriority + 1, 3) = .GetValueList()(iPriority)
Next
End With
wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
Next
End Sub
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
I've got an excel spreadsheet with several columns, two of them have an ID (that repeats itself) and a date.
What I'm trying to accomplish is to delete all rows by ID leaving only the row with the max date.
I have a second sheet with all the unique IM's.
This is what I have at the moment:
Public Sub sbMaxDateByIM()
Dim max As Date
Dim currentIM As String
Dim MaxDateCurrentIM As Date
Dim dateRange As Range
Dim imrange As Range
Application.Sheets("sheet1").Activate
Set dateRange = ActiveSheet.Range(ActiveSheet.Range("E2"), ActiveSheet.Range("E2").End(xlDown))
Set imrange = ActiveSheet.Range(ActiveSheet.Range("A2"), ActiveSheet.Range("A2").End(xlDown))
Application.ScreenUpdating = False
Application.Sheets("UniqueIMS").Activate
For IM = 1 To ActiveSheet.Range(ActiveSheet.Range("A1"), ActiveSheet.Range("A1").End(xlDown)).Rows.Count
currentIM = Sheets("UniqueIMS").Cells(IM, 1).Value
MaxDateCurrentIM = Evaluate("=MAX(IF(""imrange""=""currentIM"",))""dateRange""")
For J = 2 To Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count + 1
If currentIM = Sheets("Sheet1").Cells(IM, 1).Value And CDate(Sheets("Sheet1").Cells(J, 5).Value) < MaxDateCurrentIM Then
Rows(J).EntireRow.Delete
End If
Next J
Next IM
Application.ScreenUpdating = True
End Sub
Any ideias would be very much appreciated, the line of code not working is:
MaxDateCurrentIM = Evaluate("=MAX(IF(""imrange""=""currentIM"",))""dateRange""")
Can you try this? Your formula syntax was off I think. (Also why set currentIM twice?) Plus, when deleting rows you need to go backwards.
Public Sub sbMaxDateByIM()
Dim max As Date
Dim currentIM As String
Dim MaxDateCurrentIM As Date
Dim dateRange As Range
Dim imrange As Range
With Sheets("sheet1")
Set dateRange = .Range(.Range("E2"), .Range("E2").End(xlDown))
Set imrange = .Range(.Range("A2"), .Range("A2").End(xlDown))
End With
Application.ScreenUpdating = False
Application.Sheets("UniqueIMS").Activate
For IM = 1 To Range(Range("A1"), Range("A1").End(xlDown)).Rows.Count
currentIM = Sheets("sheet1").Cells(IM, 1).Value
MaxDateCurrentIM = Evaluate("=MAX(IF(" & imrange.Address & "=""" & currentIM & """," & dateRange.Address & "))")
For J = Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count + 1 To 2 Step -1
If currentIM = Sheets("Sheet1").Cells(IM, 1).Value And CDate(Sheets("Sheet1").Cells(J, 5).Value) < MaxDateCurrentIM Then
Rows(J).EntireRow.Delete
End If
Next J
Next IM
Application.ScreenUpdating = True
End Sub
Evaluate is used to run Excel functions - but Excel has no idea what imrange and currentim are, they only exist inside the vba routine. You either need to rewrite your maxif in terms excel understands, or use vba code to do the same job as maxif
I am trying to implement some VBA code such that if the word, "LowLimit" in the first row. If found, then carry out the calculations and move to next sheet. If not found, then go to next sheet.
I have declared the word "LowLimit", Dim lowLimHdr As String. How do implement the IF...THEN using this argument before entering into my calculations?
This is what I have so far:
Sub ReturnMarginal()
'UpdatebySUPERtoolsforExcel2016
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWks As Worksheet
Dim InterSectRange As Range
Dim lowLimCol As Integer
Dim hiLimCol As Integer
Dim measCol As Integer
Dim lowLimHdr As String
Application.ScreenUpdating = False
Set xWb = ActiveWorkbook
For Each xWks In xWb.Sheets
xRow = 1
With xWks
FindString = "LowLimit"
'If
.Cells(xRow, 16) = "Meas-LO"
.Cells(xRow, 17) = "Meas-Hi"
.Cells(xRow, 18) = "Min Value"
.Cells(xRow, 19) = "Marginal"
LastRow = .UsedRange.Rows.Count
lowLimCol = Application.WorksheetFunction.Match("LowLimit", xWks.Range("1:1"), 0)
hiLimCol = Application.WorksheetFunction.Match("HighLimit", xWks.Range("1:1"), 0)
measLimCol = Application.WorksheetFunction.Match("MeasValue", xWks.Range("1:1"), 0)
.Range("P2:P" & LastRow).Formula = "=" & Cells(2, measLimCol).Address(False, False) & "-" & Cells(2, lowLimCol).Address(False, False)
.Range("Q2:Q" & LastRow).Formula = "=" & Cells(2, hiLimCol).Address(False, False) & "-" & Cells(2, measLimCol).Address(False, False)
.Range("R2").Formula = "=min(P2,Q2)"
.Range("R2").AutoFill Destination:=.Range("R2:R" & LastRow)
.Range("S2").Formula = "=IF(AND(R2>=-3, R2<=3), ""Marginal"", R2)"
.Range("S2").AutoFill Destination:=.Range("S2:S" & LastRow)
End With
Application.ScreenUpdating = True 'turn it back on
Next xWks
End Sub
If Not xWks.Rows(1).Find(FindString) Is Nothing Then
' do your calculations
End If
You need to dim your variables lowLimCol, HighLimCol and measCol as Variants because in the case of no match, Application.Match returns an error variant, otherwise a number that represents the index of the found column.
Dim lowLimCol. hiLimCol, measCol
lowLimCol = Application.Match("LowLimit", xWks.Range("1:1"), 0)
hiLimCol = Application.Match("HighLimit", xWks.Range("1:1"), 0)
measLimCol = Application.Match("MeasValue", xWks.Range("1:1"), 0)
' Check if all these columns were found in the header to proceed:
If Not (IsError(lowLimCol) Or IsError(highLimCol) Or IsError(measLimCol)) Then
'
' You calculations here
'
End If
p.s. the variable lowLimHdr is your code seems unnecessary.
You could also keep them declared as integers and then use
If Application.WorksheetFunction.CountIf(Range("1:1"), LowLimHdr) > 0 Then
' do all my calcuations in here
End If
That's assuming that any sheet with "LowLimit" will definitely have the other headers too, otherwise previous answer is better for error catching.
EDIT: In a similar vein to A.S.H's answer, to do full error catching in case any of the headers are missing you'd need a triple check:
If Application.WorksheetFunction.CountIf(Range("1:1"), "LowLimit") > 0 And _
Application.WorksheetFunction.CountIf(Range("1:1"), "HighLimit") > 0 And _
Application.WorksheetFunction.CountIf(Range("1:1"), "MeasValue") > 0 Then
' do all my calcuations in here
End If
Basically, have this code which uses Vlookups and a match to find past order dates of a particular product. The sub fills text boxes in a userform with N/A if there are no past orders found in the sheet. Otherwise, finds the latest order and fills the information in the userform.
The program stops when this sub routine is called. Getting 'subscript out of range' (error 9), I run the debugger and go through the code and everything works the way it is supposed to. In both the N/A case and the case where there is past order info.
Sub PastOrderInfo()
Dim wks As Worksheet
Dim Date_Ordered As Variant
Dim PreviousDate As Variant
Dim Qty_Ordered As String
Dim Total_Cost As String
Dim Rng, RngCol As String
Dim Last_Row As Long
Dim i, NewRow As Integer
Set wks = Worksheets("Order Data")
With wks
Last_Row = .UsedRange.Rows(.UsedRange.Rows.count).Row
Rng = "A2:D" & Last_Row
RngCol = "A2:A" & Last_Row
For i = 2 To Last_Row
If i = 2 Then
On Error Resume Next
PreviousDate = Application.VLookup(CStr(ProdNum), .Range(Rng), 2, False)
On Error GoTo 0
If IsError(PreviousDate) Then
Me.TextBox4.Value = "N/A"
Me.TextBox5.Value = "N/A"
Me.TextBox6.Value = "N/A"
Exit Sub
End If
NewRow = Application.Match(CStr(ProdNum), .Range(RngCol), 0) + 2
Rng = "A" & NewRow & ":D" & Last_Row
RngCol = "A" & NewRow & ":A" & Last_Row
ElseIf i > 2 Then
On Error Resume Next
Date_Ordered = Application.VLookup(CStr(ProdNum), .Range(Rng), 2, False)
On Error GoTo 0
If IsError(Date_Ordered) Then
NewRow = NewRow - 1
Rng = "A" & NewRow & ":D" & Last_Row
Me.TextBox4.Value = CDate(PreviousDate)
Me.TextBox5.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 3, False)
Me.TextBox6.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 4, False)
Exit Sub
End If
NewRow = Application.Match(CStr(ProdNum), .Range(RngCol), 0) + NewRow
Rng = "A" & NewRow & ":D" & Last_Row
RngCol = "A" & NewRow & ":A" & Last_Row
If Date_Ordered > PreviousDate Then PreviousDate = Date_Ordered
End If
Next i
Me.TextBox4.Value = CDate(PreviousDate)
Me.TextBox5.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 3, False)
Me.TextBox6.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 4, False)
End With
End Sub
Here is the line which is the section of code which opens the userform, when I click to debug it highlights the ProDescription.Show line below the if .Range(cellselect)...:
Private Sub CommandButton1_Click()
Dim i, r, c As Integer
Dim wks As Worksheet
Dim cellselect As String
Set wks = Workbooks("Data Direct Orders2.xlsx").Worksheets("Direct Items")
With wks
If ProdNumberCmbBox.ListIndex = -1 Then
Unload Me
ErrorMsg.Show
End
Else
For r = 2 To 84
cellselect = "A" & r
If .Range(cellselect).Text = ProdNum Then
ProDescription.Show
Unload Me
End
End If
Next r
If c = 0 Then
Unload Me
ErrorMsg.Show
End
End If
End If
End With
End Sub
Here is the sub routine where the userform is initialized:
Private Sub UserForm_Initialize()
TextBox8.Value = ProdNum
Call PastOrderInfo
End Sub
Just figured it out.
The line:
Set wks = Worksheets("Order Data")
in
Sub PastOrderInfo()
Was the problem. Needed to specify the workbook, so after adding:
Set wks = Workbooks("VBA - Final Project.xlsm").Worksheets("Order Data")
It worked!