VBA: Index/Match with multiple criteria - vba

I'm currently trying to figure out how to write a macro that will allow me to run a index/match with two criteria. I have a large database of information containing transaction information from multiple countries. I'd like to reference data in the "country" column and "date" column to match with a separate worksheet that contains foreign exchange rates. For countries and dates that match it would return the exchange rate for that date. I'd like the macro to run down to the last row of data in my sheet (it varies from time to time)
The formula syntax I originally created is:
=INDEX('FX_Index Lookup'!G:G,MATCH('Tool'!CJ2&'Tool'!DT2,'FX_Index Lookup'!C:C&'FX_Index Lookup'!H:H,0),FALSE)
When I drag this formula down, excel runs out of resources to continue running the calculation on the amount of data (rows) I need. I was hoping a Macro could solve this issue

The last function MatchQuery will return cells in column ReturnCol, where CriteriaColA = CriteriaA, CriteriaColB = CriteriaB... (similar syntax to SUMIFS)
Set rngRes = MatchQuery(ReturnCol, CriteriaColA, CriteriaA, CriteriaColB, CriteriaB ... etc)
Public Function IsRange(ByRef vnt As Variant) As Boolean
If IsObject(vnt) Then
If Not vnt Is Nothing Then
IsRange = TypeOf vnt Is Excel.Range
End If
End If
End Function
Public Function Union(ByRef rng1 As Range, _
ByRef rng2 As Range) As Range
If rng1 Is Nothing Then
Set Union = rng2
Exit Function
End If
If rng2 Is Nothing Then
Set Union = rng1
Exit Function
End If
If Not rng1.Worksheet Is rng2.Worksheet Then
Exit Function
End If
Set Union = Application.Union(rng1, rng2)
End Function
Public Function MatchAll(ByRef vntLookupValue As Variant, _
ByRef rngLookupArray As Range) As Range
Dim rngArea As Range
Dim rngTemp1 As Range
Dim rngTemp2 As Range
Dim vntMatch As Variant
Dim lngCount As Long
Dim lngLast As Long
If rngLookupArray Is Nothing Then
Exit Function
End If
For Each rngArea In rngLookupArray.Areas
If rngArea.Columns.Count > rngArea.Rows.Count Then
Set rngTemp1 = rngArea.Rows
Else
Set rngTemp1 = rngArea.Columns
End If
For Each rngTemp2 In rngTemp1
With rngTemp2
lngCount = .Cells.Count
lngLast = 0
Do
vntMatch = Application.Match(vntLookupValue, .Parent.Range(.Cells(lngLast + 1), .Cells(lngCount)), 0)
If IsError(vntMatch) Then
Exit Do
End If
lngLast = lngLast + vntMatch
Set MatchAll = Union(MatchAll, .Cells(lngLast))
Loop Until lngLast = lngCount
End With
Next rngTemp2
Next rngArea
End Function
Public Function MatchQuery(ByRef rngLookupArray As Range, _
ParamArray avntArgs() As Variant) As Range
Dim rngResult As Range
Dim i As Long
Dim rngTemp As Range
Dim rngMatches As Range
Set rngResult = rngLookupArray
For i = 0 To UBound(avntArgs) - 1 Step 2
If Not IsRange(avntArgs(i)) Then
Exit Function
End If
Set rngTemp = avntArgs(i)
Set rngMatches = MatchAll(avntArgs(i + 1), Intersect(rngResult.EntireRow, rngTemp))
If rngMatches Is Nothing Then
Exit Function
End If
Set rngResult = Application.Intersect(rngResult, rngMatches.EntireRow)
Next i
Set MatchQuery = rngResult
End Function

Related

VBA: repeat a value a number of times

I have an input table in range A2: D6, I want each value in input range to be shown 4 times in output
range A8: D27
Below is the code it is copying only one value to the output range.
Could you please guide me on how to change this VBA code to get the desired result as shown in the below picture.
Sub RepeatData()
Dim Rng As Range
Dim lr As Integer
Dim C As Integer
Range(("A8"), Range("D10000")).ClearContents
lr = Range(("A1"), Range("A2").End(xlDown)).Count
C = 4
Dim InputRng As Range, OutRng As Range
Set InputRng = Range("A2", Range("d" & lr))
Set OutRng = Range("a8")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1", "a1").Value
xNum = 4 ' No. of times to repeat
OutRng.Resize(xNum, C).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next
End Sub
I can see that you are looping through entire input rows, so I would propose a solution copying entire rows.
Sub RepeatData()
Dim inputWorksheet As Worksheet
Dim inputRange As Range
Dim outputRangeStart As Range
Dim rowToBeCopied As Range
Dim firstFreeRow As Range
Dim numberOfOutputRows As Integer
Dim outputRange As Range
' set all params
Set inputWorksheet = Sheet1
Set inputRange = inputWorksheet.Range("A2:D5")
Set outputRangeStart = inputWorksheet.Range("A8")
numberOfOutputRows = 4
' clean output range
Range(outputRangeStart, outputRangeStart.End(xlDown).End(xlToRight)).ClearContents
' copy values
For Each rowToBeCopied In inputRange.Rows
Set firstFreeRow = FindFirstFreeCell(outputRangeStart)
Set outputRange = ExtendRangeByNumberOfRows(firstFreeRow, numberOfOutputRows)
rowToBeCopied.Copy
outputRange.PasteSpecial xlPasteValues
Next rowToBeCopied
End Sub
Function FindFirstFreeCell(startFrom As Range) As Range
If IsEmpty(startFrom) Then
Set FindFirstFreeCell = startFrom
ElseIf IsEmpty(startFrom.Offset(1, 0)) Then
Set FindFirstFreeCell = startFrom.Offset(1, 0)
Else
Set FindFirstFreeCell = startFrom.End(xlDown).Offset(1, 0)
End If
End Function
Function ExtendRangeByNumberOfRows(rangeToBeExtended As Range, numberOfRows As Integer) As Range
Set ExtendRangeByNumberOfRows = Range(rangeToBeExtended, rangeToBeExtended.Offset(numberOfRows - 1, 0))
End Function

VBA Delete row if

All i want to do is to optimize my current delete row code.
At this stage this step take to much time.
Dim miesiac2 As Integer '--->current month
miesiac2 = Range("b1").Value
Dim LastRow As Long
LastRow = [A65536].End(xlUp).Row
For i = LastRow To 1 Step -1
If Cells(i, 1) = miesiac2 Then Rows(i & ":" & i).EntireRow.Delete
Next i
So... If column A equals current month then EntireRow.Delete
Any idea?
That's something I have built so far:
Option Explicit
Public Sub TestMe()
Application.ScreenUpdating = False
Dim miesiac2 As Long
Dim LastRow As Long
Dim i As Long
Dim rRange As Range
miesiac2 = Range("b1").Value
LastRow = [A65536].End(xlUp).Row 'xl2003
For i = LastRow To 1 Step -1
If Cells(i, 1) = miesiac2 Then
If rRange Is Nothing Then
Set rRange = Rows(i)
Else
Set rRange = Union(rRange, Rows(i))
End If
End If
Next i
If Not rRange Is Nothing Then rRange.Select
Application.ScreenUpdating = True
End Sub
It uses a Union and it selects the rows instead of deleting them. Its for visibility reasons, but you can fix it.
Furthermore, the 65K rows are only in Excel 2003, in later versions the rows are 1Mln+. Last but not least - do not use integer in Excel, its slow and dangerous.
This is what I could cook up in hurry
Sub delete_on_condition()
Dim wb_export As Workbook
Dim wb_export_sheet As Worksheet
Dim arr_raw_dump As Variant
Dim arr_final
Dim findcell As Range
Set wb_export = ThisWorkbook ' CHANGE IT IF REQURIED
Set wb_export_sheet = wb_export.Sheets(1) 'CHANGE IT IF REQUIRED
Dim ctr As Long
ctr = 0
With wb_export_sheet.Range("A1").CurrentRegion ' OR With wb_export_sheet.USEDRANGE
Do
Set findcell = .Find("SOME TEXT")
If ctr = 0 And findcell Is Nothing Then
MsgBox "No data found"
Exit Sub
End If
wb_export_sheet.Rows(findcell.Row).Delete
Set findcell = .Find("SOMETEXT")
ctr = ctr + 1
Loop While Not findcell Is Nothing
End With
End Sub

ModifyAppliesToRange not working

I have a worksheet with many duplicated Conditional Formatting instances.
I'm trying to write code to tidy/delete many of them.
I need to modify the Format Condition.
Any idea why the following doesn't work?
Sub UpdateCondition(ByRef bFirst As Boolean, rng As Range, f As FormatCondition, replacementFormula As String)
If bFirst Then
f.Modify f.Type, , replacementFormula
f.ModifyAppliesToRange rng
bFirst = False
Else
f.Delete
End If
End Sub
I get the following error:
Method 'ModifyAppliesToRange' of object 'FormatCondition' failed
This code works for many of my conditions. Only some of them trip up.
-- edit --
My calling code is as follows
Dim f As FormatCondition
Dim bFirst As Boolean
Dim i As Integer
Set rng = SomeRangeOnTheSheet
bFirst = True
For i = ActiveSheet.Range(Cells.Address).FormatConditions.Count To 1 Step -1
Set f = ws.Range(Cells.Address).FormatConditions(i)
If f.Formula1 = "..Some Formula.." Then
UpdateCondition bFirst, rng, f, replacementFormula
End If
Next
-- edit --
Function SomeRangeOnTheSheet() As Range
Dim cell1 As Range
Dim cell2 As Range
Set cell1 = Cells(Range("Roster").row, Range("StartDate").Column)
Set cell2 = Cells(Range("Roster").row + Range("Roster").Rows.Count - 1, Range("Roster").Column + Range("Roster").Columns.Count - 1)
Set RosterDataRange = Range(cell1, cell2)
End Function

VBA 'Vlookup' function operating on dynamic number of rows

I am not sure how to combine a Function with a Sub. Most likely, the Sub I have below needs corrections.
I have two tables in two separate sheets: Sheet1 and Sheet2.
Both tables have dynamic number of rows but the first rows always start in the same place and the number of columns in both tables is constant, too. Sheet1 data starts in A2 and ends in R2:R and Sheet2 data starts in A3 and ends in H3:H.
I am trying to implement VLOOkUP in column O of Sheet1, that would populate each cell in column O of Sheet1 with relevant values of column D in Sheet2. So far I managed to come up with code as below.
Public Function fsVlookup(ByVal pSearch As Range, ByVal pMatrix As Range, ByVal pMatColNum As Integer) As String
Dim s As String
On Error Resume Next
s = Application.WorksheetFunction.VLookup(pSearch, pMatrix, pMatColNum, False)
If IsError(s) Then
fsVlookup = ""
Else
fsVlookup = s
End If
End Function
Public Sub Delinquency2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim rCell As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
pSearch = ws1.Range("D2:D" & Cells(Rows.Count, "A").End(xlDown).Row)
pMatrix = ws2.Range("$A3:$H" & Cells(Rows.Count, "C").End(xlDown).Row)
pMatColNum = 4
Set rng = ws1.Range("O2:O" & Cells(Rows.Count, "A").End(xlDown).Row)
For Each rCell In rng.Cells
With rCell
rCell.FormulaR1C1 = s
End With
Next rCell
End Sub
You will need to call the function in your sub using a similar line to below. It then takes your values from your sub and inputs them into the function and returns the value.
You need to dim the ranges in order for them to be recognized correctly in your function. I have updated your code to make it work and you can fiddle around with it to make it work the way you want it to. I also updated a few other spots to figure out the correct ranges, you don't want to use xlDown where you were using it, causes an enormous loop covering cells you don't want it to.
Public Function fsVlookup(ByVal pSearch As Range, ByVal pMatrix As Range, ByVal pMatColNum As Integer) As String
Dim s As String
On Error Resume Next
s = Application.WorksheetFunction.VLookup(pSearch, pMatrix, pMatColNum, False)
If IsError(s) Then
fsVlookup = ""
Else
fsVlookup = s
End If
End Function.
Public Sub Delinquency2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim rCell As Range, pMatrix As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
pSearchCol = ws1.Range("D2:D2").Column
Set pMatrix = ws2.Range("$A3:$H" & ws2.Cells(Rows.Count, "C").End(xlUp).Row)
pMatColNum = 4
Set rng = ws1.Range("O2:O" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
For Each rCell In rng.Cells
With rCell
rCell.Value = fsVlookup(ws1.Cells(rCell.Row, pSearchCol), pMatrix, pMatColNum)
End With
Next rCell
End Sub

show range in message box VBA

I have a function that selects a range based on a whole bunch of criteria from Sheet2. I'm trying to copy this range and to show/paste on Sheet1 or have it show in a message box.
Public Function findrulepos(target As Range, destination As Range) As String
Dim ruleStart As Range
Dim ruleEnd, ruleEnd2 As String
Dim Xcell, PasteRangeIndexCell As Range
Dim RuleRange As Range
Dim LastCell As Range
Dim FirstCell, IndexCell As Range
Dim WholeRule As Range
MaxRule = 100000
MaxRow = 100000
Sheets("ResRules").Select
For i = 2 To MaxRow
If CStr(ThisWorkbook.Sheets("ResRules").Range("A" & i).Value) = CStr(target.Value) Then
Set ruleStart = ThisWorkbook.Sheets("ResRules").Range("B" & i) '.offset(0, 1)
Exit For
End If
Next i
'MsgBox (ruleStart.address)
Set FirstCell = ruleStart.offset(1, -1)
Set IndexCell = FirstCell
Do Until IndexCell.Value <> "" Or IndexCell.Row >= MaxRow
Set IndexCell = IndexCell.offset(1, 0)
Loop
If IndexCell.Value <> "" Then
Set LastCell = IndexCell.offset(-1, 1)
MsgBox (LastCell.Value)
Else
Set LastCell = Nothing
End If
Set WholeRule = ThisWorkbook.Sheets("ResRules").Range("" & ruleStart.address & ":" & LastCell.address & "")
End Function
This is the whole code to give me the range I require
I have added a watch and can see I am getting the correct range i.e. $B$3:$B$6 but cant copy this range to Sheet 1
If your function is being called from a worksheet cell, then copy/paste won't work since that type of function can only return a value to the cell in which it resides. You need a function called from a Sub.
Use the following to get the address:
Sheet1.Range("A1").value = WholeRule.address
or, if you want to copy the actual content in the cells:
WholeRule.copy Sheet1.Range("A1")
thanks guys
worked it out
changed it to a Sub then
Public Sub ReturnRuleButton()
Call findrulepos(ThisWorkbook.Sheets("Main").Cells(2, 5), ThisWorkbook.Sheets("Main").Cells(2, 6))
End Sub