In the cell A1 of my Excel sheet named 'Sheet2' has the following formula (CSE Array Formula)
{=INDEX(Data1, MATCH(F26&G26,Data2&Data3,0),7)}
Data1 = Sheet1!$D$3:$J$604
Data2 = Sheet1!$D$3:$D$604
Data3 = Sheet1!$D$3:$E604
I want to rewrite this in VBA Macro, and the below is what I have tried so far (Yes, it is giving me an error (ERROR: Can't assign to array)
Sub Button1_Click()
Dim var1(1 To 10) As Integer
Dim var2(1 To 10) As Integer
With Application.WorksheetFunction
var1 = .Match((F26 And G26), (Worksheets("Sheet1").Range("D3:D604") And Worksheets("Sheet1").Range("E3:E604")), 0)
var2 = .Index(Worksheets("Sheet1").Range("D3:J604"), var1, 7)
Range("A1").Value = var2
End With
End Sub
Any suggestion/correction please?
why are you defining var1 and var2 as arrays?
To concatenate strings, use the same & operator as the formula: (F26 & G26)
To concatenate ranges, use the Application.Union() method: Application.Union(range1, range2)
I assume from the function, you want to return an array of all the places in your area that match the values in F26 and G26
This would be my attempt:
Option Explicit
Sub Button1_Click()
Dim Values()
Dim FindData
Dim Counter As Long
Dim DataPoints As Long
Dim ReturnData()
ReDim ReturnData(1)
DataPoints = 1
Values = Application.Union(Range("D3::D604"),Range("E3:E604"))
FindData = Range("F26").Value & Range("G26").Value
For Counter = LBound(Values) To UBound(Values)
If findata = (Values(Counter, 1) & Values(Counter, 2)) Then
ReDim Preserve ReturnData(DataPoints)
ReturnData(DataPoints) = Counter
DataPoints = DataPoints + 1
End If
Next
Range("A1:A" & DataPoints) = ReturnData
End Sub
Related
I am a VBA beginner, who cannot seem to find a solution to what seemed to be a very easy comparison to me at first.
Basically, I have 2 columns where the values in the cells are split by a delimiter, however, not in the same order.
eg.
Range("A1").value = "1234|5678"
Range("B1").value = "5678|1234"
B1 should then be highlighted as a duplicate
I am searching for some vba code which I can use to loop through the used range's in Columns A & B, to compare and highlight cells in column B that are duplicated, as per example above.
Apologies if I missed any similar questions asked and answered previously, I have indeed conducted a search but perhaps my search criteria may have been out of bounds, and I simply did not come across the VBA solution.
Regards,
Enjay
Based on the little information given you could try the following code
Sub Highlight()
Const DELIMITER = "|"
Dim rg As Range
Dim a As Variant
Dim b As Variant
Dim sngCell As Range
Set rg = Range("A1:A3")
For Each sngCell In rg
a = Split(sngCell.Value2, DELIMITER)
b = Split(sngCell.Offset(, 1).Value2, DELIMITER)
If isEqual(a, b) Then
With sngCell.Offset(, 1).Interior
.ThemeColor = xlThemeColorAccent6
End With
End If
Next sngCell
End Sub
with the following functions
Function isEqual(a As Variant, b As Variant) As Boolean
a = BubbleSort(a)
b = BubbleSort(b)
isEqual = True
Dim i As Long
For i = LBound(a) To UBound(a)
If a(i) <> b(i) Then
isEqual = False
Exit For
End If
Next i
End Function
Function BubbleSort(ByRef strArray As Variant) As Variant
'sortieren von String Array
'eindimensionale Array
'Bubble-Sortier-Verfahren
Dim z As Long
Dim i As Long
Dim strWert As Variant
For z = UBound(strArray) - 1 To LBound(strArray) Step -1
For i = LBound(strArray) To z
If LCase(strArray(i)) > LCase(strArray(i + 1)) Then
strWert = strArray(i)
strArray(i) = strArray(i + 1)
strArray(i + 1) = strWert
End If
Next i
Next z
BubbleSort = strArray
End Function
This will answer your question as-is. If the solution needs to be adjusted, I trust that you can fix it :)
This uses StrComp to (in memory only) re-order the two string parts so that it can easily detect duplicate values.
Option Explicit
Sub DuplicateCheck()
Dim delimiter As String
delimiter = "|"
Dim lastCol As Long
lastCol = Cells(1, Columns.count).End(xlToLeft).Column
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To lastCol
Dim theSplit As Variant
theSplit = Split(Cells(1, i), delimiter)
Dim temp As String
If StrComp(theSplit(0), theSplit(1), vbTextCompare) = 1 Then
temp = theSplit(1)
theSplit(1) = theSplit(0)
theSplit(0) = temp
End If
temp = theSplit(0) & delimiter & theSplit(1)
If Not dict.exists(temp) Then
dict.Add (temp), 1
Else
Cells(1, i).Interior.color = 65535
End If
Next i
End Sub
I need to get a range of cells into an array, which by itself is simple enough:
Dim matchArray As Variant
matchArray = Sheets(lookupSheet).Range("B2:B12000").Value2
This creates a two-dimensional array with one column as the second dimension and if you expand the range to include a second column it creates a two-dimensional array with two columns for the second dimension:
matchArray = Sheets(lookupSheet).Range("B2:C12000").Value2
But what if the two columns aren't next to each other and you don't want the one in the middle?
matchArray = Sheets(lookupSheet).Range("B2:B12000,D2:D12000").Value2
The above would be my best guess but it doesn't work, it only returns the first range specified.
So what I need is a way to return a range cell values into a specific dimension of the array.
I know I could do it by looping through the rows but that would take far too long with the number of rows I'm going to be working with.
You do need a loop -- but loop over VBA arrays rather than individual cells:
Sub Test()
Dim A As Variant, B As Variant, C As Variant
Dim i As Long
B = Sheets(lookupSheet).Range("B2:B12000").Value2
C = Sheets(lookupSheet).Range("D2:D12000").Value2
ReDim A(1 To 11999, 1 To 2)
For i = 1 To 11999
A(i, 1) = B(i, 1)
A(i, 2) = C(i, 2)
Next i
'do stuff with A
End Sub
This should only take a fraction of a second.
You can do it with a ragged array:
Dim var1(1 To 2) As Variant
Dim var As Variant
var = Range("A1:A10").Value2
var1(1) = var
var = Range("c1:c10").Value2
var1(2) = var
MsgBox var1(1)(3, 1)
Here are a couple more ways:
Sub Example1()
Const lookupSheet As String = "Sheet1"
Dim matchArray As Variant, arr1 As Variant, arr2 As Variant
With Sheets(lookupSheet)
arr1 = WorksheetFunction.Transpose(.Range("B2:B12000").Value2)
arr2 = WorksheetFunction.Transpose(.Range("D2:D12000").Value2)
matchArray = WorksheetFunction.Transpose(Array(arr1, arr2))
End With
End Sub
Sub Example2()
Const lookupSheet As String = "Sheet1"
Dim matchArray As Variant
Dim x As Long
With Sheets(lookupSheet)
matchArray = .Range("B2:B12000").Resize(, 2).Value2
For Each v In .Range("D2:D12000").Value2
x = x + 1
matchArray(x, 2) = v
Next
End With
End Sub
Probably no quicker than John Coleman's answer, but I think this does what you want.
Sub x()
Dim matchArray, r As Range
Set r = Sheets(lookupSheet).Range("B2:D12000")
matchArray = Application.Index(r, Evaluate("Row(1:" & r.Rows.Count & ")"), Array(1, 3))
End Sub
I am trying to do the following :
VBA to lookup a value from a particular cell
Match these values in a particular column in specified sheets
Delete all rows from the sheet if the value do not match
I have tried the following - the code doesn't seem to function
Sub Delete()
Dim List As Variant
Dim LR As Long
Dim r As Long
List = Worksheets("Sheet1").Cells(28, "C").Value
LR = Range("E" & Rows.Count).End(xlUp).Row
For r = LR To 1 Step -1
If IsError(Application.Match(Range("E" & r).Value, List, False)) Then
Worksheets("Sheet2").Range("A1:AA36429").Rows(r).Delete
End If
Next r
End Sub
Try this:
Sub Delete()
Dim i As Integer
Dim LR As Long
Dim List As Variant
LR = Range("E" & Rows.Count).End(xlUp).Row
List = Worksheets("Sheet1").Cells(28, "C").Value
For i = 1 To LR
If Cells(i, "E").Value = List Then
Worksheets("Sheet1").Rows(i).Delete
End If
Next i
End Sub
I think you have a few ways of going about this, but the quickest way I know of is to use MATCH to compare values in a range to values in an array. Please note that this has a limit to 4000 or so values to compare before it fails. For your purposes, I think the following will work:
Sub test1()
Dim x As Long
Dim array1() As Variant
Dim array2() As Variant
array1 = Array("ABC", "XYX")
array2 = Range("A1:A2")
If IsNumeric(Application.Match(Range("A1").Value, array1, 0)) Then
x = 1
ElseIf IsNumeric(Application.Match(Range("A1").Value, array2, 0)) Then
x = IsNumeric(Application.Match(Range("A1").Value, array2, 0))
End If
'If x is not found in these arrays, x will be 0.
MsgBox x
End Sub
Another similar way is the following:
Sub test2()
Dim array1() As Variant
Dim FilterArray() As String
Dim x As Variant
x = Range("A1").Value
array1 = Array("ABC", "RANDOM", "VBA")
FilterArray = Filter(SourceArray:=array1, _
Match:=strText, _
Include:=True, _
Compare:=vbTextCompare)
If UBound(FindOutArray) = -1 Then
MsgBox "No, Array doesn't contain this item - " & x
Else
MsgBox "Yes, Array contains this item - " & x
End If
End Sub
So if we were to incorporate that all together (and I tested this btw):
Sub Delete()
Dim i As Integer
Dim LR As Long
Dim List() As Variant
Dim x As Long
LR = Range("E" & Rows.count).End(xlUp).Row
List = Worksheets("Sheet1").Range("A1:A2").Value
For i = 1 To LR
If IsNumeric(Application.Match(Cells(i, "E").Value, List, 0)) Then
Worksheets("Sheet1").Cells(i, "E").Value = ""
End If
Next i
Worksheets("Sheet1").Columns("E").SpecialCells(xlCellTypeBlanks).Cells.Delete
End Sub
This will set the cells that have values that are found in the array to blanks. Once the loop is finished, then the blank cells are deleted. If you want to shift the entire rows up, then use this as the last line instead:
Worksheets("Sheet1").Columns("E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
I have been in search of an solution that would allow an Excel user to enter a formula, similar to a vlookup, that would return all unique matching values to a single cell.
I wrote the following code that seems to work, but I am trying to run the function in 2000+ cells and it runs pretty slow on my Thinkstation-S30 and I am afraid it will crash anyone trying to open the file from a slower machine. Does anyone have any thoughts on how to make the function more efficient? I apologize for the sloppy code, i am an accountant by trade...
Public Function MvalLookup(Lookup_vector As Range, Result_vector As Range,_
Criteria As Variant, Seperator As String)
'
' Returns a list of all unique values matching the criteria
'
Dim arr As New Collection, a
Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim result As String
Dim lookuprange As Integer
z = Lookup_vector.Rows.Count
j = 0
On Error Resume Next
For lookuprange = 1 To z
'determine how many values match- determine the required array size
If CStr(Lookup_vector(lookuprange, 1)) = CStr(Criteria) Then
arr.Add CStr(Result_vector(lookuprange, 1)), CStr(Result_vector(lookuprange, 1))
j = j + 1
End If
Next lookuprange
' Write results
result = arr(1)
If arr.Count <= 1 Then GoTo Output
For i = 2 To arr.Count
result = result & Seperator & arr(i)
Next
Output:
'Output results
MvalLookup = result
End Function
Thanks for the link Ralph, the suggestions in that article really helped. Just by storing the ranges as array's, took almost 10 seconds off the processing time!
Here is the revised code:
Public Function MvalLookup(Lookup_vector As Range, Result_vector As Range,_
Criteria As Variant, Seperator As String)
'
' MValLookup Macro
' Returns a list of all unique values matching the criteria
'
Dim arr As New Collection, a
Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim result As String
Dim lookuprange As Integer
Dim LUVect As Variant
Dim RESVect As Variant
z = Lookup_vector.Rows.Count
j = 0
LUVect = Lookup_vector.Value2
RESVect = Result_vector.Value2
On Error Resume Next
For lookuprange = 1 To z
'determine how many values match- determine the required array size
If CStr(LUVect(lookuprange, 1)) = CStr(Criteria) Then
arr.Add CStr(RESVect(lookuprange, 1)), CStr(RESVect(lookuprange, 1))
j = j + 1
End If
Next lookuprange
' Write results
result = arr(1)
If arr.Count <= 1 Then GoTo Output
For i = 2 To arr.Count
result = result & Seperator & arr(i)
Next
Output:
'Output results
MvalLookup = result
End Function
I've written a macro that takes a 2 dimensional array, and "prints" it to equivalent cells in an excel workbook.
Is there a more elegant way to do this?
Sub PrintArray(Data, SheetName, StartRow, StartCol)
Dim Row As Integer
Dim Col As Integer
Row = StartRow
For i = LBound(Data, 1) To UBound(Data, 1)
Col = StartCol
For j = LBound(Data, 2) To UBound(Data, 2)
Sheets(SheetName).Cells(Row, Col).Value = Data(i, j)
Col = Col + 1
Next j
Row = Row + 1
Next i
End Sub
Sub Test()
Dim MyArray(1 To 3, 1 To 3)
MyArray(1, 1) = 24
MyArray(1, 2) = 21
MyArray(1, 3) = 253674
MyArray(2, 1) = "3/11/1999"
MyArray(2, 2) = 6.777777777
MyArray(2, 3) = "Test"
MyArray(3, 1) = 1345
MyArray(3, 2) = 42456
MyArray(3, 3) = 60
PrintArray MyArray, "Sheet1", 1, 1
End Sub
On the same theme as other answers, keeping it simple
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
Sub Test()
Dim MyArray() As Variant
ReDim MyArray(1 To 3, 1 To 3) ' make it flexible
' Fill array
' ...
PrintArray MyArray, ActiveWorkbook.Worksheets("Sheet1").[A1]
End Sub
Create a variant array (easiest by reading equivalent range in to a variant variable).
Then fill the array, and assign the array directly to the range.
Dim myArray As Variant
myArray = Range("blahblah")
Range("bingbing") = myArray
The variant array will end up as a 2-D matrix.
A more elegant way is to assign the whole array at once:
Sub PrintArray(Data, SheetName, StartRow, StartCol)
Dim Rng As Range
With Sheets(SheetName)
Set Rng = .Range(.Cells(StartRow, StartCol), _
.Cells(UBound(Data, 1) - LBound(Data, 1) + StartRow, _
UBound(Data, 2) - LBound(Data, 2) + StartCol))
End With
Rng.Value2 = Data
End Sub
But watch out: it only works up to a size of about 8,000 cells. Then Excel throws a strange error. The maximum size isn't fixed and differs very much from Excel installation to Excel installation.
As others have suggested, you can directly write a 2-dimensional array into a Range on sheet, however if your array is single-dimensional then you have two options:
Convert your 1D array into a 2D array first, then print it on sheet (as a Range).
Convert your 1D array into a string and print it in a single cell (as a String).
Here is an example depicting both options:
Sub PrintArrayIn1Cell(myArr As Variant, cell As Range)
cell = Join(myArr, ",")
End Sub
Sub PrintArrayAsRange(myArr As Variant, cell As Range)
cell.Resize(UBound(myArr, 1), UBound(myArr, 2)) = myArr
End Sub
Sub TestPrintArrayIntoSheet() '2dArrayToSheet
Dim arr As Variant
arr = Split("a b c", " ")
'Printing in ONE-CELL: To print all array-elements as a single string separated by comma (a,b,c):
PrintArrayIn1Cell arr, [A1]
'Printing in SEPARATE-CELLS: To print array-elements in separate cells:
Dim arr2D As Variant
arr2D = Application.WorksheetFunction.Transpose(arr) 'convert a 1D array into 2D array
PrintArrayAsRange arr2D, Range("B1:B3")
End Sub
Note: Transpose will render column-by-column output, to get row-by-row output transpose it again - hope that makes sense.
HTH
My tested version
Sub PrintArray(RowPrint, ColPrint, ArrayName, WorkSheetName)
Sheets(WorkSheetName).Range(Cells(RowPrint, ColPrint), _
Cells(RowPrint + UBound(ArrayName, 2) - 1, _
ColPrint + UBound(ArrayName, 1) - 1)) = _
WorksheetFunction.Transpose(ArrayName)
End Sub
You can define a Range, the size of your array and use it's value property:
Sub PrintArray(Data, SheetName As String, intStartRow As Integer, intStartCol As Integer)
Dim oWorksheet As Worksheet
Dim rngCopyTo As Range
Set oWorksheet = ActiveWorkbook.Worksheets(SheetName)
' size of array
Dim intEndRow As Integer
Dim intEndCol As Integer
intEndRow = UBound(Data, 1)
intEndCol = UBound(Data, 2)
Set rngCopyTo = oWorksheet.Range(oWorksheet.Cells(intStartRow, intStartCol), oWorksheet.Cells(intEndRow, intEndCol))
rngCopyTo.Value = Data
End Sub