I keep getting the Argument not optional compiler error in vba and can't figure out why.
I can't see any typos, I don't even take any arguments and the subroutine only executes on a button click.
Public Sub SearchAMLinesForIDs_Click()
Dim time As String
time = "AM"
Dim end_row As Long
end_row = Range("A2").End(xlDown).row
Dim lookup_end_row As Long
Dim lookup_result As Long
lookup_end_row = ThisWorkbook.Sheets(time & "_Lines").Range("A2").End(xlDown).row
lookup_table = ThisWorkbook.Sheets(time & "_Lines").Range("A2:C" & lookup_end_row)
Dim row As Long
For row = 1 To end_row
lookup_result = WorksheetFunction.VLookup(Range("A" & row), lookup_table, 1, False)
Cells(row + 1, 2) = lookup_result
Next row
End Sub
Public Sub SearchAMLinesForIDs_Click()
Dim sTime As String, shtData As Worksheet, sht As Worksheet
Dim lookup_result, rngLookup As Range
Dim rw As Long
sTime = "AM"
Set shtData = ThisWorkbook.Worksheets(sTime & "_Lines")
Set sht = ActiveSheet
Set rngLookup = shtData.Range(shtData.Range("A2"), shtData.Cells(shtData.Rows.Count, 1).End(xlUp))
For rw = 2 To sht.Range("A2").End(xlDown).row
'don't use Worksheetfunction, but test the return value for errors...
lookup_result = Application.VLookup(sht.Cells(rw, 1), rngLookup, 1, False)
sht.Cells(rw, 2) = IIf(IsError(lookup_result), "NoMatch!", lookup_result)
Next rw
End Sub
Utilize your object browser if you're running into issues like this.
You can test your vlookup within a cell in a worksheet to verify validity.
Your parenthesis are in incorrect order.
lookup_result = WorksheetFunction.VLookup(Cells(1 + Row, 1), _
ThisWorkbook.Sheets(Time & "_Lines").Range(Cells(2, 1), Cells(lookup_end_row, 1)), _
1, _
False)
parenthesis opened for Range doesn't close and closed in the end.
Related
Given the following spreadsheet of data: https://ethercalc.org/q7n9zwbzym5y
I have the following code that will parse this and will derive a tree from the parent-child relationships in the sheet. Note that fact that every column occurs twice is because the first instance of the columns is for another type of data, I am only concerned with the populated columns. This is the desired output from the sheet above:
Code:
Sub performanceSheet(someParams)
' Write to "Performance" sheet
Dim w1 As Worksheet, w2 As Worksheet, wsSearch As Worksheet, wsData As Worksheet
Dim num_rows
Dim parent As Range, parentName As String
Dim parentRange As Range, childrenRange As Range
Dim childCount As Long
Dim p As Variant
Dim f1 As Range, f2 As Range
currRow = 8
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set w1 = wbk.Sheets("PositionsDB")
Set w2 = wbk.Sheets("Performance")
num_rows = w1.Cells(Rows.Count, 1).End(xlUp).row
'If there's no parentName column, we can't continue.
If w1.Rows(1).Find("portfolioName") Is Nothing Then Exit Sub
'find first instance
Set f1 = w1.Rows(1).Find("portfolioName", lookat:=xlWhole)
If Not f1 Is Nothing Then
'find second instance
Set f2 = f1.Offset(0, 1).Resize(1, w1.Columns.Count - f1.Column).Find("portfolioName", lookat:=xlWhole)
If Not f2 Is Nothing Then
'set range based on f2
Set parentRange = w1.Range(f2.Offset(1, 0), _
w1.Cells(Rows.Count, f2.Column).End(xlUp))
End If
End If
'If there's no Root level, how do we know where to start?
If parentRange.Find("Main") Is Nothing Then Exit Sub
For Each parent In parentRange
If Not dict.Exists(parent.Value) Then
childCount = Application.WorksheetFunction.CountIf(parentRange, parent.Value)
Set childrenRange = parent.Offset(, 2).Resize(childCount, 1)
dict.Add parent.Value, Application.Transpose(Application.Transpose(childrenRange.Value))
End If
Next
' Recursive method to traverse our dictionary, beginning at Root element.
Call PerformanceProcessItem("", "Main", dict, w2, 9)
wbk.Sheets("Performance").Columns("A:F").AutoFit
End Sub
Private Sub PerformanceProcessItem(parentName As String, name As String, dict As Object, ws As Worksheet, row_num As Long, Optional indent As Long = 0)
Dim output As String, v
Dim w2 As Worksheet
'Debug.Print WorksheetFunction.Rept(" ", indent) & name
'Debug.Print parentName & name
'write to sheet
ws.Cells(row_num, 3).Value = name
row_num = row_num + 1
If Not dict.Exists(name) Then
'we're at a terminal element, a child with no children.
Exit Sub
Else
For Each v In dict(name)
' ## RECURSION ##
Call PerformanceProcessItem(name, CStr(v), dict, ws, row_num, indent + 2)
Next
End If
End Sub
However, when creating this tree, it gets stuck on an infinite loop of India's, where after recognizing "Cash" as the terminal element of India, rather than exiting that subtree it will create another India and continue until overflow. Is there a logic error in my code? Hours of debugging hasn't worked for me and any input would be appreciated on where I have a flaw in my logic.
I am assuming that "Main" and "Cash" will always be there. If not then we will have to tweak the code little bit. I have commented the code so you may not have a problem understanding it. But if you do, simply ask. I quickly wrote this code so I am sure it can be optimized :)
Option Explicit
Dim sB As String
Dim tmpAr As Variant
Sub Sample()
Dim col As New Collection
Dim s As String
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim itm As Variant, vTemp As Variant
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Get Last Row of Col AA
lRow = .Range("AA" & .Rows.Count).End(xlUp).Row
'~~> Store Range AA:AC in an array
tmpAr = .Range("AA2:AC" & lRow).Value
End With
'~~> Create a unique collection of portfolioName
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 1) = "Main" Then
On Error Resume Next
col.Add tmpAr(i, 3), CStr(tmpAr(i, 3))
On Error GoTo 0
End If
Next i
'~~> Sort the collection
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i) > col(j) Then
vTemp = col(j)
col.Remove j
col.Add vTemp, vTemp, i
End If
Next j
Next i
s = "Main"
For Each itm In col
sB = vbTab & itm
s = s & vbNewLine & sB
sB = ""
GetParentChild itm, 2
If Trim(sB) <> "" Then _
s = s & vbNewLine & sB
Next itm
s = s & vbNewLine & vbTab & "Cash"
Debug.Print s
End Sub
Private Sub GetParentChild(strg As Variant, n As Integer)
Dim sTabs As String
Dim j As Long, k As Long
For k = 1 To n
sTabs = sTabs & vbTab
Next k
For j = LBound(tmpAr) To UBound(tmpAr)
If Trim(tmpAr(j, 1)) = Trim(strg) And Trim(tmpAr(j, 1)) <> "Cash" Then
sB = sB & sTabs & tmpAr(j, 3) & vbNewLine
GetParentChild tmpAr(j, 3), n + 1
End If
Next j
End Sub
This is what I got when I ran it on the data that you provided.
I have an output excel file from another macro which has multiple sheets (named 100,101,102... etc.) Sheet numbers will vary depending on prior macro's output.
Also there is a sheet named sheet1 which has info about how many random rows should be selected from 100,101,102... etc.
I tried to merge/combine what i could find from similar macros but i guess the loop part is way over my head.
I will run the macro from another "main" excel. which will open related output xls.
Then it will lookup for random rows amount from sheet1 and then select that number of random rows in related sheet and move to next sheet. (I'm getting the correct amount from lookup (used index match))
But for randomized part i was not able to make it work for multiple sheets.
It does not matter if it selects and colors the rows or copies and pastes them to another sheet/wb. Both is ok, but I need to automate this process since i have so much data waiting.
The macro i have managed so far is below, since I'm a newbie there may be unrelated or unnecessary things.
Is it possible?
Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
StartTime = Now()
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Integer
Dim I As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xls")
SheetN = mvn.Worksheets.Count
Set SampleS = mvn.Sheets("Sheet1")
For Each Sh In mvn.Worksheets
Sh.Activate
If Sh.Name <> "Sheet1" Then
Dim lookupvalue As Integer
Dim ranrows As Integer
Dim randrows As Integer
lookupvalue = Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(mvn.Sheets("Sheet1")_
.Range("S1:S304"), Application.WorksheetFunction.Match(lookupvalue,
mvn.Sheets("Sheet1").Range("$D$1:$D$304"), 0))
'MsgBox lookupvalue & " " & ranrows
End If
Next Sh
Durat = Round((Now() - StartTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Here is an example (i have integrated some code, adapted from other places, and added the references in to the code itself) I would welcome feedback from other users and can refine.
Sheet1 has the number of rows to return and the sheet names (i have used a short list)
The other sheets have some random data e.g. Sheet2
The code reads the sheet names into one array and the number of rows to randomly choose from each sheet into another array.
It then loops the sheets, generates the number of required random rows by selecting between the first and the start row in the sheet (this currently doesn't have error handling in case specified number of random rows exceeds available number ,but then could set numRows to lastRow. Union is used to collect these for the given sheet and they are copied to the next available row in the target sheet of another workbook. Union can't be used across worksheets sadly so a workaround has to be found, i chose this copy for each worksheet.
I have made some assumptions about where to copy from and to but have a play. I have also left some of your code in and currently set mnv = ThisWorkbook and the workbook to copy to is called otherWorkbook. Yours may be differently named and targeted but this was aimed at showing you a process for generating numbers and copying them in a loop.
Have used a function by Rory to test if the worksheet exists.
Example result:
Option Explicit
Public Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
'Dim SheetN As Long
Dim i As Long
Dim otherWorkbook As Workbook
Dim targetSheet As Worksheet
Dim startTime As Date
Dim mnv As Workbook
Dim SampleS As Worksheet
startTime = Now()
FPath = ThisWorkbook.Path
'Set mvn = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\" & Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value & " Muavinbol" & ".xls")
Set mnv = ThisWorkbook
Set otherWorkbook = Workbooks.Open("C:\Users\HarrisQ\Desktop\My Test Folder\Test.xlsx")
Set targetSheet = otherWorkbook.Sheets("TargetSheet")
Set SampleS = mnv.Worksheets("Sheet1")
Dim worksheetNames()
Dim numRandRows()
worksheetNames = SampleS.Range("$D$1:$D$3").Value
numRandRows = SampleS.Range("$S$1:$S$3").Value
Dim copyRange As Range
Dim currSheetIndex As Long
Dim currSheet As Worksheet
Dim selectedRows As Range
For currSheetIndex = LBound(worksheetNames, 1) To UBound(worksheetNames, 1)
If WorksheetExists(CStr(worksheetNames(currSheetIndex, 1))) Then
Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))
With currSheet
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
firstRow = GetFirstLastRow(currSheet, 1)(0) 'I am using Column A (1) to specify column to use to find first and last row.
lastRow = GetFirstLastRow(currSheet, 1)(1)
numRows = numRandRows(currSheetIndex, 1)
Set selectedRows = RandRows(currSheet, firstRow, lastRow, numRows) 'Union cannot span different worksheets so copy paste at this point
Dim nextTargetRow As Long
If IsEmpty(targetSheet.Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
End If
selectedRows.Copy targetSheet.Cells(nextTargetRow, 1)
Set selectedRows = Nothing
End With
End If
Next currSheetIndex
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function RandRows(ByRef currSheet As Worksheet, ByVal firstRow As Long, ByVal lastRow As Long, ByVal numRows As Long) As Range
'http://www.ozgrid.com/VBA/RandomNumbers.htm
Dim iArr As Variant
Dim selectedRows As Range
Dim i As Long
Dim r As Long
Dim temp As Long
Application.Volatile
ReDim iArr(firstRow To lastRow)
For i = firstRow To lastRow
iArr(i) = i
Next i
For i = lastRow To firstRow + 1 Step -1
r = Int(Rnd() * (i - firstRow + 1)) + firstRow
temp = iArr(r)
iArr(r) = iArr(i)
iArr(i) = temp
Next i
Dim currRow As Range
For i = firstRow To firstRow + numRows - 1
Set currRow = currSheet.Cells.Rows(iArr(i))
If Not selectedRows Is Nothing Then
Set selectedRows = Application.Union(selectedRows, currRow)
Else
Set selectedRows = currRow
End If
Next i
If Not selectedRows Is Nothing Then
Set RandRows = selectedRows
Else
MsgBox "No rows were selected for copying"
End If
End Function
Private Function GetFirstLastRow(ByRef currSheet As Worksheet, ByVal colNum As Long) As Variant
'colNum determine which column you will use to find last row
Dim startRow As Long
Dim endRow As Long
endRow = currSheet.Cells(currSheet.Rows.Count, colNum).End(xlUp).Row
startRow = FirstUsedCell(currSheet, colNum)
GetFirstLastRow = Array(startRow, endRow)
End Function
Private Function FirstUsedCell(ByRef currSheet As Worksheet, ByVal colNum As Long) As Long
'Finds the first non-blank cell in a worksheet.
'https://www.excelcampus.com/library/find-the-first-used-cell-vba-macro/
Dim rFound As Range
On Error Resume Next
Set rFound = currSheet.Cells.Find(What:="*", _
After:=currSheet.Cells(currSheet.Rows.Count, colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
MsgBox currSheet & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function WorksheetExists(sName As String) As Boolean
'#Rory https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Since QHarr's code needed to have all worksheet names should exist in the workbook did not work for me in the end. But with merging it some other project's function i made it work.
Opens an output xlsx file in same folder,
Index&Match to find the random rows amount
loop through all sheets with random function
then paste all randomized rows into Sheet named RASSAL
It may be unefficient since I really dont have much info on codes, but guess i managed to modify it into my needs.
Open to suggestions anyway and thanks to #QHarr very much for His/Her replies.
Sub RASSALFNL()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim Durat As Long
startTime = Now()
Dim Sht As Worksheet
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Long
Dim i As Long
Dim lookupvalue As Long
Dim indexrange As Range
Dim matchrange As Range
Dim ranrows As Long
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
Dim sayf As String
Dim nextTargetRow As Long
Dim Rassal As Worksheet
Dim rngToCopy As Range
Dim sampleCount As Long
Dim ar() As Long
Dim total As Long
Dim rowhc As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xlsx")
SheetN = mvn.Worksheets.count
Set SampleS = mvn.Sheets("Sheet1")
Set Rassal = Worksheets.Add
Rassal.Name = "RASSAL"
Set indexrange = SampleS.Range("$S$8:$S$304")
Set matchrange = SampleS.Range("$D$8:$D$304")
mvn.Activate
For Each Sht In mvn.Worksheets
Sht.Activate
If Sht.Name = "Sheet1" Or Sht.Name = "Sayfa1" Or Sht.Name = "RASSAL"
Then
'do nothing
Else
lookupvalue = Sht.Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(indexrange,
Application.WorksheetFunction.Match(lookupvalue, matchrange, 0))
With Sht
firstRow = GetFirstLastRow(Sht, 1)(0)
lastRow = GetFirstLastRow(Sht, 1)(1)
numRows = ranrows
sayf = Sht.Name
'MsgBox sayf & " " & firstRow & " " & lastRow & " " &
ranrows
If numRows = 0 Then
'do nothing
Else
ar = UniqueRandom(numRows, firstRow, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
If IsEmpty(mvn.Sheets("RASSAL").Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow =
mvn.Sheets("RASSAL").Cells(mvn.Sheets("RASSAL").Rows.count,
"A").End(xlUp).Row + 1
End If
rngToCopy.Copy Rassal.Cells(nextTargetRow, 1)
Set rngToCopy = Nothing
End If
End With
End If
Next Sht
rowhc = Rassal.Cells(Rows.count, 1).End(xlUp).Row
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
MsgBox rowhc & " " & "random selections made in" & " " & Durat & "
seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function GetFirstLastRow(ByRef Sht As Worksheet, ByVal colNum As
Long) As Variant
'colNum determine which column you will use to find last row
Dim firstRow As Long
Dim lastRow As Long
lastRow = Sht.Cells(Sht.Rows.count, colNum).End(xlUp).Row
firstRow = FirstUsedCell(Sht, colNum)
GetFirstLastRow = Array(firstRow, lastRow)
End Function
Private Function FirstUsedCell(ByRef Sht As Worksheet, ByVal colNum As
Long) As Long
Dim rFound As Range
On Error Resume Next
Set rFound = Sht.Cells.Find(What:="*", _
After:=Sht.Cells(Sht.Rows.count,
colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
'do Nothing MsgBox Sh & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function UniqueRandom(ByVal numRows As Long, ByVal a As Long, ByVal b As
Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
If numRows = 0 Then
ReDim Preserve arr(0)
Else
ReDim Preserve arr(0 To numRows - 1)
On Error Resume Next
End If
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x '
swap
Next
Next
UniqueRandom = arr
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 have a spreadsheet that has values for more than one month, so I am trying to first find the value based on a value in the wsRevFile worksheet and then ensure that this is the value from last month. When I use the following code, I get a "invalid number of arguments" error.
Sub RevLookup(wsMvFile As Worksheet, wsRevOld As Worksheet, wsNewRev As Worksheet, _
rowCount As Integer, workCol As String, _
srcCol1 As Integer, srcCol2 As Integer)
Dim vrw As Variant, i As Long
For i = 2 To rowCount
vrw = Application.Match(wsRevFile.Range("A" & i), wsNewRev.Columns(2), Format(DateSerial(Year(Date), Month(Date), 0), "mm/dd/yyyy"), wsNewRev.Columns(1), 0)
If IsError(vrw) Then
vrw = Application.Match(wsRevFile.Range("A" & i), wsRevOld.Columns(1), 0)
If Not IsError(vrw) Then _
wsRevFile.Range(workCol & i) = Application.Index(wsRevOld.Columns(srcCol1), vrw)
Else
wsRevFile.Range(workCol & i) = Application.Index(wsNewRev.Columns(srcCol2), vrw, 1)
End If
Next i
End Sub
I am assuming this has to do with the way I assigned the Application Match function, because the formula without this part works for other columns. Any ideas on how I could get this to work?
Thanks for your help!
Try ajusting the variables of the following procedure, as I didn't figure out your input and output data:
Sub Main()
Dim SearchValue As Variant
Dim SearchColumn As Range
Dim ReturnColumn As Range
Dim ResultRows As Collection
Dim LastDate As Variant 'Date?
Dim iRow As Variant
SearchValue = 10 '<-- change to suit
Set SearchColumn = wsNewRev.Range("B1:B10")
Set ReturnColumn = wsNewRev.Range("C1:C10") '<-- change to suit
Set ResultRows = GetLoopRows(SearchColumn, SearchValue)
For Each iRow In ResultRows
If LastDate < ReturnColumn(iRow) Then
LastDate = ReturnColumn(iRow)
End If
Next iRow
Debug.Print LastDate
End Sub
Function GetLoopRows(ParamArray pParameters() As Variant) As Collection
'Obtém limites de laços com levando em conta condições
'[vetor1], [valor1], [vetor2], [valor2], ...
Dim iCondition As Long
Dim i As Variant
Dim iRow As Variant
Dim Result As Collection
Dim NumConditions As Long
Dim SearchCollection As Collection
Dim ArraysCollection As Collection
Dim iArray As Variant
NumConditions = (UBound(pParameters) - LBound(pParameters) + 1) / 2
Set ArraysCollection = New Collection
Set SearchCollection = New Collection
For i = LBound(pParameters) To UBound(pParameters) Step 2
ArraysCollection.Add pParameters(i + 0).Value2
SearchCollection.Add pParameters(i + 1)
Next i
Set Result = New Collection
For iRow = LBound(ArraysCollection(1)) To UBound(ArraysCollection(1))
For iCondition = 1 To NumConditions
If ArraysCollection(iCondition)(iRow, 1) <> SearchCollection(iCondition) Then GoTo Continue
Next iCondition
Result.Add CLng(iRow)
Continue:
Next iRow
Quit:
Set GetLoopRows = Result
End Function
This works Lastrow = 8, but not 9 (Type mismatch)
If i remove If Not (myarray = Empty) Then it does not work for 8
What is the easiest way to solve this?
Public Function GetRowToWriteOn(ByVal SheetName As String, ByVal idnr As Integer) As Integer
LastRow = (Sheets(SheetName).UsedRange.Rows.Count) + 1
MsgBox (LastRow)
myarray = Sheets(SheetName).Range("d8:d" & LastRow).Value
If Not (myarray = Empty) Then
For row = 1 To UBound(myarray, 1)
If (myarray(row, 1) = idnr) Then
GetRowToWriteOn = row
Exit Function
End If
Next
End If
GetRowToWriteOn = LastRow
Exit Function
End Function
MyArray is taking 2 different types, depending on the range given.
If you are looking at 1 cell, then it is a single variant (which can be tested if it is Empty)
If you are looking at 2 or more cells, then it becomes an array of variant, so you would have to test each cell.
myarray = Sheets(SheetName).Range("d8:d8").Value - myarray gets the value in d8
myarray = Sheets(SheetName).Range("d8:d9").Value - myarray(1,1) gets the value in d8, and myarray(2,1) gets the value in d9
to test, use:
if vartype(myarray)=vbArray then
' run through the array
else
' do single value stuff
endif
I feel like your code should look more like this
Option Explicit
Public Function GetRowToWriteOn(ByVal SheetName As String, ByVal idnr As Integer) As Integer
Dim lastrow As Long, row As Long
lastrow = (Sheets(SheetName).UsedRange.Rows.Count) + 1
MsgBox (lastrow)
Dim myarray() As Variant
myarray = Sheets(SheetName).Range("d8:d" & lastrow).Value
If Not (IsEmpty(myarray)) Then
For row = 1 To UBound(myarray, 1)
If (myarray(row, 1) = idnr) Then
GetRowToWriteOn = row
Exit Function
End If
Next
End If
GetRowToWriteOn = lastrow
Exit Function
End Function
BUT I also think there is another way to do what you want. A little simpler and used built in functions. I think I captured your intention here:
Dim RowToWriteOn As Long, SheetName As String, lastRow As Long
Dim rng As Range
SheetName = "Sheet1"
lastRow = (Sheets(SheetName).UsedRange.Rows.Count) + 1
Set rng = Sheets(SheetName).Range("d" & lastRow)
RowToWriteOn = rng.End(xlUp).row
Public Function GetRowToWriteOn(ByVal SheetName As String, _
ByVal idnr As Integer) As Long
Dim lastRow As Long, f As Range
lastRow = Sheets(SheetName).Cells(Rows.Count, 4).End(xlUp).Row
Set f = Sheets(SheetName).Range("D8:D" & lastRow).Find(what:=idnr, _
lookat:=xlWhole)
If Not f Is Nothing Then
GetRowToWriteOn = f.Row
Else
GetRowToWriteOn = lastRow + 1
End If
End Function
myarray = Sheets(SheetName).Range("d8:d" & LastRow)
(without value)...
And you can use: if ubound(myArray) > 1 then ;..
I think it could be as easy as this, no...?