I'm not a VBA developer but i need a function multile values return of a VLOOKUP.
I found this one:
Public Function CercaTableMultiplo(lookupval, lookuprange As Range, indexcol As Long)
'updateby Extendoffice 20151118
Dim x As Range
Dim result As String
result = ""
For Each x In lookuprange
If x = lookupval Then
result = result & " " & x.Offset(0, indexcol - 1)
End If
Next x
CercaTableMultiplo = result
End Function
i edit it as fallow
Public Function CercaTableMultiplo(lookupval, lookuprange As Range, indexcol As Long, delimitator)
Dim x As Range
Dim result As String
result = ""
Dim first As Boolean
first = True
For Each x In lookuprange
If x = lookupval Then
If first = True Then
result = result & x.Offset(0, indexcol - 1)
first = False
Else
result = result & delimitator & x.Offset(0, indexcol - 1)
End If
End If
Next x
CercaTableMultiplo = result
End Function
The parameters are (F217;Foglio2!E:G;3;", ")
It works when:
the first column is little the second is empty and the third is populate.
Not works when:
the first column is little the second is populate (like a description text) and the third is populate.
I suppose it is a overflow issue but my short VBA developer experience stops here,
there are some checking that can i do?
Related
I'm trying to look for values to create a final ticket number for a ticket reconciliation process. This is what should happen:
subroutine looks for a value in cell "Gx"
if it finds a value
pass value to function to strip out letters, convert to a number, pass back to subroutine to place in
cell "Ax"
if there is no value
pass value of "Cx" to function etc.
This loops through the number cells I have in my worksheet based on the number of rows filled in a separate column.
The function works fine by itself in the worksheet, but when I pass it a value from the subroutine column A fills up with the number of the row ie. A37=37, A8=8. I don't think I'm passing the argument correctly to the function, but I'm not certain. Here's the code for the subroutine and the function:
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
'header label
Range("A1").Value = "Final Ticket #"
'set number of rows for loop
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
'check col G for empty, use col C as backup
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
'strip out letters in col G, place in col A
Cells(i, "A").Value = getNumeric("G" & i)
Else
'strip out letters in col C, place in col A
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
stringLength = Len(cellRef)
'loops through each character in a cell to evaluate if number or not
For i = 1 To stringLength
If IsNumeric(Mid(cellRef, i, 1)) Then
Result = Result & Mid(cellRef, i, 1)
End If
Next i
'convert remaining characters to number
getNumeric = CLng(Result)
End Function
What am I missing?
As I understand it, the only thing that is wrong is your Len (cellRef), here you are only passing the range and not his value. See how I did it, I had to specify the spreadsheet, do the same that will work.
Use debug.print to see the outputs of the variables. Write in the code "debug.print XvariableX" and in the immediate check (Ctrl + G) you see the value assigned to the variable. good luck.
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
Range("A1").Value = "Final Ticket #"
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
Cells(i, "A").Value = getNumeric("G" & i)
Else
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
Dim Wrs As String
Wrk = ActiveWorkbook.Name
Workbooks(Wrk).Activate
Wrs = ActiveSheet.Name
stringLength = Len(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef))
For i = 1 To stringLength
If IsNumeric(Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)) Then
Result = Result & Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)
End If
Next i
getNumeric = CLng(Result)
End Function
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'm having some problem with the following code.
rng is a range that represents quite a large table. E.g. A1:G600. refArr is a list of row numbers. I need the following code to pass back a range so that just the rows from refArr can be selected out of rng.
However, when my refArr is too long (i.e. when it has over 54 items exactly) it gives me an error.... Any ideas why this would be the case?
Function RangeSelector(rng As Range, refArr As Variant) As Range
Set RangeSelector = Intersect(rng, rng.Range("A" & Replace(Join(refArr, ","), ",", ",A")).EntireRow.Offset(1))
End Function
The problem is that the maximum string length for Range is 255. We can get around that by using Union.
Notice that Range.address will only return 255 characters even if the actual address is much longer
In the test I use RangeSelector to select every other row from 1 to 600
Test
Sub TestRangeSelector()
Const MAXROWS As Long = 300
Dim refArr(1 To MAXROWS), x As Long
Dim Target As Range
For x = 1 To MAXROWS
refArr(x) = x * 2
Next
Set Target = RangeSelector(Range("A1:G600"), refArr)
Target.Select
Debug.Print "Absolute Address: "; Len(Target.Address), Target.Address
Debug.Print "Relative Address: "; Len(Target.Address(False, False)), Target.Address(False, False)
End Sub
RangeSelector
Function RangeSelector(rng As Range, refArr) As Range
Dim s As String, Target As Range, v As Variant, x As Long
For x = LBound(refArr) To UBound(refArr)
s = s & refArr(x) & ":" & refArr(x) & ","
If x = UBound(refArr) Or Len(s) >= 251 Then
s = Left(s, Len(s) - 1)
If Target Is Nothing Then
Set Target = rng.Range(s)
Else
Set Target = Union(Target, rng.Range(s))
End If
s = ""
End If
Next
Set RangeSelector = Intersect(rng, Target)
End Function
Dear stackoverflow community
At work I have to write a macro which should be able to hide rows based on numbers in a column. Those can be multiple ones in one cell and the input should also allow to show more than one number at a time.
for example:
row 1: 20, 30, 15
row 2: 20
row 3: 13, 76
So if I enter 20, 30, it should only show rows 1 & 2)
I usually code with Java / c# and Im new to VBA, so Id really appreciate help:
My plan was to show a input box and split those numbers into an array.
Then i wanna go through each row with a for-Loop, in which i added two for each loops to check if any numbers equal. If not, hide row. If so, show and then i want to exit both for each loops and go to the next row. To exit nested loops, i tried using a do while boolean but it doesnt seem to work.
Right now it only shows the rows with all the input numbers (only row1 in example).
Sub SortingTest()
Dim numbers() As String
myNum = Application.InputBox("Enter BKPS (separate multiples by , )")
numbers = Split(myNum, ",", -1, compare)
'Userinput Vars
Dim row As Integer
row = 1
Dim saveNumber As String
'Looping Vars
Dim existingNum As String
Dim existingNumsArray() As String
Dim checkRows As Long
Dim saveElement As String
Dim done As Boolean
done = False
' Range("B3").Value = 10
' Saves the Input as Array:
For Each Element In numbers
saveNumber = Element
Cells(2, row).Value = saveNumber
row = row + 1
Next Element
Dim b As Integer
Do While done = False
For b = 1 To 100 'hardcoded, should be length of document. b == row;
existingNum = Cells(b, 3).Value
existingNumsArray = Split(existingNum, ",", -1, compare)
' loop thru input numbers
For Each Element In numbers
saveElement = Element
'loop thru given numbers
For Each inputElement In existingNumsArray
If saveElement <> inputElement Then
Rows(b).Hidden = True
ElseIf saveElement = inputElement Then
Rows(b).Hidden = False
done = True
Exit For
End If
Next
Next
Next
Loop
End Sub
Thank you very much for you answer. Yours hid all the rows, so i adjusted it to show them.
Option Explicit
Function ArrOr(a As Variant, b As Variant) As Boolean
Dim runner As Variant
ArrOr = True
If IsArray(a) Then
For Each runner In a
If ArrOr(runner, b) Then Exit Function
Next
Else
For Each runner In b
If Trim(a) = Trim(runner) Then Exit Function
Next
End If
ArrOr = False
End Function
Sub SortingBKPS()
Dim numbers As Variant, vars As Variant, i As Long, xRows As Range
numbers = Split(Application.InputBox("Enter BKPS (separate multiples by , )"), ",")
With Sheets("Sheet1")
vars = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Value2
For i = 2 To UBound(vars)
.Rows(i).EntireRow.Hidden = True
If ArrOr(Split(vars(i, 1), ","), numbers) Then
If xRows Is Nothing Then
Set xRows = .Rows(i)
Else
Set xRows = Union(xRows, .Rows(i))
End If
End If
Next
xRows.EntireRow.Hidden = False
End With
End Sub
By splitting it up it is very easy to do:
Option Explicit
Function ArrOr(a As Variant, b As Variant) As Boolean
Dim runner As Variant
ArrOr = True
If IsArray(a) Then
For Each runner In a
If ArrOr(runner, b) Then Exit Function
Next
Else
For Each runner In b
If Trim(a) = Trim(runner) Then Exit Function
Next
End If
ArrOr = False
End Function
Sub SortingTest()
Dim numbers As Variant, vars As Variant, i As Long, xRows As Range
numbers = Split(Application.InputBox("Enter BKPS (separate multiples by , )"), ",")
With Sheets("Sheet1")
vars = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Value2
For i = 1 To UBound(vars)
If ArrOr(Split(vars(i, 1), ","), numbers) Then
If xRows Is Nothing Then
Set xRows = .Rows(i)
Else
Set xRows = Union(xRows, .Rows(i))
End If
End If
Next
xRows.EntireRow.Hidden = True
End With
End Sub
by running this code line by line, it should be pretty much self explaining (also knowing you have already some knowledge in "coding")
Still, if you have any questions, just ask ;)
You can also do it the following way:
Sub SortingTest()
Dim numbers As Variant
Dim RangeCompare As Range
Dim MyRow As Integer
Dim NumFound As Boolean
numbers = Application.InputBox("Please,list the values in this format: " & _
vbCrLf & "{value, value, value, ...}", _
Default:="{#, #, #}", Type:=64)
For MyRow = 1 To Cells(Rows.Count, 1).End(xlUp).row
Set RangeCompare = Range(Cells(MyRow, 1), Cells(MyRow, Columns.Count).End(xlToLeft))
NumFound = False
For Each rCell In RangeCompare
For Each Element In numbers
If rCell = Element Then
NumFound = True
Exit For
End If
Next Element
If NumFound = True Then Exit For
Next rCell
If NumFound = False Then
Rows(MyRow).Hidden = True
End If
Next MyRow
End Sub
I think it's easy to understand but feel free to ask for explanation.
I have this code for finding the column letter of a given header:
Public Function GetColumnLetter(ByRef in_cells As Range, ByVal column_header As String, Optional look_at As Excel.XlLookAt = xlPart) As String
GetColumnLetter = Split(in_cells.Find(what:=column_header, LookAt:=look_at, SearchOrder:=xlByRows).Address(ColumnAbsolute:=False), "$")(0)
End Function
But it seems to be a little slow. It seems to take a few seconds on some worksheets when it seems like it shouldn't take more than a second. I have to do this for a number of different columns in a number of different worksheets.
Is there a faster way of doing this?
EDIT: I just made a helper function that calls this function, but w/just the first row (in_cells.Range("1:1)), and also changed xlByRows to xlByColumns, and this has sped things enough.
For what it's worth, here is an extremely fast function that does what you want without invoking Find. According to my (very old) notes, it came from here. The parameter c represents the index of the column in question, as in the property Selection.Column.
Public Function GetColumnLetter(ByVal c As Long) As String
Dim p As Long
While c
p = 1 + (c - 1) Mod 26
c = (c - p) \ 26
GetColumnLetter = Chr$(64 + p) & GetColumnLetter
Wend
End Function
EDIT: Given clarifications in comments, here is a setup for testing .Find vs .Match, which appears to be faster. Using the variant values of the array might be faster still, but I'll leave it here.
Set up a first row of data:
Public Sub MakeUglyFirstRow()
Dim rng As Excel.Range
Dim i As Long, p As Long
Dim strChar As String
Dim initialLength As Integer
Set rng = ActiveSheet.Rows(1)
initialLength = 5
For i = 1 To rng.Cells.Count
p = 1 + (i - 1) Mod 26
strChar = String(initialLength, Chr$(64 + p))
rng.Cells(i).Value = strChar
If i Mod 26 = 0 Then initialLength = initialLength + 1
Next i
End Sub
The original function (plus error handling for a value not found), and a match version calling the function above:
Public Function GetColumnLetter_ByFind(ByRef in_cells As Range, ByVal column_header As String, Optional look_at As Excel.XlLookAt = xlPart) As String
Dim rngFound As Excel.Range
Set rngFound = in_cells.Find(what:=column_header, LookAt:=look_at, SearchOrder:=xlByRows)
If Not (rngFound Is Nothing) Then
GetColumnLetter_ByFind = Split(rngFound.Address(ColumnAbsolute:=False), "$")(0)
End If
End Function
Public Function GetColumnLetter_ByMatch(in_cells As Range, text_to_find As String, Optional look_at As Excel.XlLookAt = XlLookAt.xlPart) As String
On Error Resume Next
Dim rngFirstRow As Excel.Range
Dim result As Variant
Dim col As Long
Dim r As Long
Set rngFirstRow = in_cells.Rows(1)
col = 0
With Application.WorksheetFunction
If look_at = xlPart Then
result = .Match("*" + text_to_find + "*", rngFirstRow, 0)
Else
result = .Match(text_to_find, rngFirstRow, 0)
End If
If .IsError(result) = False Then
col = CLng(result) 'will need an offset if the range's first column is not 1
End If
End With
If col > 0 Then
GetColumnLetter_ByMatch = GetColumnLetter(col)
End If
End Function
The (very crude) test method (some parameter explanation below):
Public Sub Test_ColumnFinding(Optional testString As String = "yyy", _
Optional numberOfTests As Long = 1000, _
Optional printResults As Boolean = True, _
Optional printEvery As Integer = 10)
Dim rng As Excel.Range
Dim timStart1 As Single, timEnd1 As Single, timTotal1 As Single
Dim timStart2 As Single, timEnd2 As Single, timTotal2 As Single
Dim strTest1 As String, strTest2 As String
Dim i As Long
Set rng = ActiveSheet.Rows(1)
For i = 1 To numberOfTests
timStart1 = Timer
strTest1 = GetColumnLetter_ByFind(rng, testString, IIf(i Mod 3 = 0, XlLookAt.xlPart, XlLookAt.xlWhole))
timEnd1 = Timer
timTotal1 = timTotal1 + (timEnd1 - timStart1)
timStart2 = Timer
strTest2 = GetColumnLetter_ByMatch(rng, testString, IIf(i Mod 3 = 0, XlLookAt.xlPart, XlLookAt.xlWhole))
timEnd2 = Timer
timTotal2 = timTotal2 + (timEnd2 - timStart2)
If printResults Then
If i Mod printEvery = 0 Then
Debug.Print i, "GetColumnLetter_ByFind", strTest1, timEnd1 - timStart1
Debug.Print i, "GetColumnLetter_ByMatch", strTest2, timEnd2 - timStart2
End If
End If
Next i
Debug.Print "GetColumnLetter_ByFind took " & timTotal1 / numberOfTests & " seconds on avg to execute"
Debug.Print "GetColumnLetter_ByMatch took " & timTotal2 / numberOfTests & " seconds on avg to execute"
End Sub
Where testString controls distance to match, numberOfTests the repetition, printResults whether or not to see debug output, and printEvery how often to check in on that output.
My results, for 1000 tests but no result debug output:
GetColumnLetter_ByFind took 0.003546875 seconds on avg to execute
GetColumnLetter_ByMatch took 0.00134375 seconds on avg to execute