I am setting up a bookkeeping system using excel-vba to automatically send different values on the journal to specific accounts such as the ledger, balance sheet, income statement, etc based on category or description.
This is my first attempt to automate these accounts.
''''''
Sub ListSpecificVals()
Dim Arr() As Variant
Dim datarange, cell As Range
Dim count As Long
Set datarange = Sheet5.Range("a17:f28")
ReDim Arr(1 To 12, 1 To 6)
count = Application.WorksheetFunction.CountIf(datarange, "abc")
MsgBox count
For i = 1 To count
For Each cell In datarange
If cell.Value = "abc" Then
cell.Offset(0, 1).Value = 33
For i = 1 To count
Arr(i, 1) = cell.Address
Next i
Debug.Print cell.Address + " = "
Debug.Print cell.Offset(0, 1).Value
End If
Next cell
For i = 1 To count
Sheet5.Cells(i + 16, 10).Value = Arr
Next i
End Sub
''''
When writing the array values to the worksheet I expect each cell on the result range to give each different cell address for the cells containing "abc" in "datarange". Instead, only the last cell.address in "datarange" is written on every cell on the results range on the worksheet.
Again, when I use Debug.Print cell.Address + " = ",
Debug.Print cell.Offset(0, 1).Value as shown in the code, the immediate windows shows the results perfectly and exactly as they should come out, but when I use Debug.Print Arr(i,1) the immediate window does not show any results.
OK... second attempt at posting this. Trying to make my question make sense please be patient with me, I am new at all of this.
The code below words PERFECTLY. It reads from the Range in column A and give me a string of all the cells where the searched numbers occur.
My only issue is its obviously not condensed at all. I have tried loops and arrays for the references but i can't seem to get it work. i would prefer something along the lines of reference(1-10) in stead of ref1, ref2, ref3. i had them all ref(i) with a loop around the whole macro but i ended up getting no results and an endless loop. any help to make this more streamlined would be appreciated. i have the full code if that will help anyone. I only put three iterations of the code it simply continues on with more references. up to 9
Option Explicit
Sub FindAircraftHourly()
Dim Findarray() As Integer 'the array to put numbers in
Dim count1, count2, count3, count4, count5, count6, count7, count8, count9 As Integer 'this will count the number of records you will need for your array
Dim n1, n2, n3, n4, n5, n6, n7, n8, n9 As Integer 'this will be what gets you through your For loops
Dim Searchvalue1, Searchvalue2, Searchvalue3, Searchvalue4, Searchvalue5, Searchvalue6, Searchvalue7, Searchvalue8, Searchvalue9 As Integer 'this is the number to look for
Dim Foundstring1, Foundstring2, foundstring3, foundstring4, foundstring5, foundstring6, foundstring7, Foundstring8, Foundstring9 As String 'this will build where the numbers are found
Dim k1 As Integer
Dim data As Worksheet
Set data = ThisWorkbook.Sheets("data")
If Cells(1, 3) <> "" Then 'test to make sure it has something to look for
Searchvalue1 = Cells(1, 3) * 1 'E18 is the search value for the function this converts it to number and not text
Else
MsgBox "No input found!", vbCritical 'if blank, give a warning and quit
GoTo the_end
End If
k1 = data.Range("A5000").End(xlUp).Row
count1 = 0 'always initialize your variables
For n1 = 1 To k1 'count through all the rows to find the end of the list
If Cells(n1, 1) <> "" Then 'is the cell blank or not?
count1 = count1 + 1 'if not blank, then increase the count
Else
Exit For 'if it's blank, stop looking and counting
End If
Next n1
ReDim Findarray1(0 To count1 - 1) As Integer 'array indexes start at 0, so subtract 1 to get the right number of elements
For n1 = 0 To UBound(Findarray1) 'go from the first element to the last of the array
Findarray1(n1) = Cells(n1 + 1, 1) 'load the array change the last number in the cells box to change where to start looking
Next n1
For n1 = 0 To UBound(Findarray1)
If Findarray1(n1) = Searchvalue1 Then
If Foundstring1 = "" Then 'if this is the first time found, create the string
Foundstring1 = n1 + 1
Else
Foundstring1 = Foundstring1 & ", " & n1 + 1 'if this is the second time the number is found, add a comma and continue to build the string.
End If
End If
Next n1
If Foundstring1 = "" Then
MsgBox "Not found", vbCritical 'msgbox nothing was found
Else
Cells(1, 4) = Foundstring1 'output the string to a certain cell
End If
'-----------------------------------------------------------------------
If Cells(2, 3) <> "" Then 'test to make sure it has something to look for
Searchvalue2 = Cells(2, 3) * 1 'E18 is the search value for the function this converts it to number and not text
Else
MsgBox "No input found!", vbCritical 'if blank, give a warning and quit
GoTo the_end
End If
k1 = data.Range("A5000").End(xlUp).Row
count2 = 0 'always initialize your variables
For n2 = 1 To k1 'count through all the rows to find the end of the list
If Cells(n2, 1) <> "" Then 'is the cell blank or not?
count2 = count2 + 1 'if not blank, then increase the count
Else
Exit For 'if it's blank, stop looking and counting
End If
Next n2
ReDim FindArray2(0 To count2 - 1) As Integer 'array indexes start at 0, so subtract 1 to get the right number of elements
For n2 = 0 To UBound(FindArray2) 'go from the first element to the last of the array
FindArray2(n2) = Cells(n2 + 1, 1) 'load the array change the last number in the cells box to change where to start looking
Next n2
For n2 = 0 To UBound(FindArray2)
If FindArray2(n2) = Searchvalue2 Then
If Foundstring2 = "" Then 'if this is the first time found, create the string
Foundstring2 = n2 + 1
Else
Foundstring2 = Foundstring2 & ", " & n2 + 1 'if this is the second time the number is found, add a comma and continue to build the string.
End If
End If
Next n2
If Foundstring2 = "" Then
MsgBox "Not found", vbCritical 'msgbox nothing was found
Else
Cells(2, 4) = Foundstring2 'output the string to a certain cell
End If
'-----------------------------------------------------------
If Cells(3, 3) <> "" Then 'test to make sure it has something to look for
Searchvalue3 = Cells(3, 3) * 1 'E18 is the search value for the function this converts it to number and not text
Else
MsgBox "No input found!", vbCritical 'if blank, give a warning and quit
GoTo the_end
End If
k1 = data.Range("A5000").End(xlUp).Row
count3 = 0 'always initialize your variables
For n3 = 1 To k1 'count through all the rows to find the end of the list
If Cells(n3, 1) <> "" Then 'is the cell blank or not?
count3 = count3 + 1 'if not blank, then increase the count
Else
Exit For 'if it's blank, stop looking and counting
End If
Next n3
ReDim FindArray3(0 To count3 - 1) As Integer 'array indexes start at 0, so subtract 1 to get the right number of elements
For n3 = 0 To UBound(FindArray3) 'go from the first element to the last of the array
FindArray3(n3) = Cells(n3 + 1, 1) 'load the array change the last number in the cells box to change where to start looking
Next n3
For n3 = 0 To UBound(FindArray3)
If FindArray3(n3) = Searchvalue3 Then
If foundstring3 = "" Then 'if this is the first time found, create the string
foundstring3 = n3 + 1
Else
foundstring3 = foundstring3 & ", " & n3 + 1 'if this is the second time the number is found, add a comma and continue to build the string.
End If
End If
Next n3
If foundstring3 = "" Then
MsgBox "Not found", vbCritical 'msgbox nothing was found
Else
Cells(3, 4) = foundstring3 'output the string to a certain cell
End If
the_end: 'end marker
End Sub
I'm not sure what your data looks like, but I would suggest a few things:
'finds the absolute last row with data in it // ignores empty cells
k1 = data.UsedRange.Rows.Count
count1 = 0
For n1 = 1 To k1
'here's a built-in function to help you check empty cells.
'if you're going to reference ranges, then you need to define on which worksheet
'you're referencing the ranges from. if you work with multiple worksheets, you
'can't simply use Cells(x,y); you need to use worksheet.Cells(x,y).
'If you want to access a cell's value, then you use the .Value property.
If Not IsEmpty(data.Cells(n1, 1).Value) Then
count1 = count1 + 1
Else
Exit For
End If
Next n1
I highly suggest using Collections instead of arrays because, for me, they're far easier to deal-with than arrays. They also start their indices at 1, so if you have a collection of 10 items, you count 1 through 10 instead of 0 through 9.
Defining and setting Collections:
Dim FindArray As New Collection
Or
Dim FindArray As Collection
Set FindArray = New Collection
Iterating over a collection:
Dim v As Variant
Dim sample As Double
For Each v In FindArray
'i personally like to recast all variant types to
'the intended data type
sample = v
'do your thing here
Next
Or
For i = 0 To FindArray.Count
'do your other thing here
Next
Here's my attempt at making your code cleaner; hope it helps!
PS: All my castings are based on assumptions, so change them to whatever type you were intending.
Main:
Dim wb As Workbook
Dim data As Worksheet
Dim n As Long
Dim SearchValue As Double
Dim Found As String
Dim output As New Collection
Dim FindArray As Collection
Dim count As Long
Dim k As Long
Dim i As Long
Dim j As Long
Set wb = Excel.Application.ThisWorkbook
Set data = wb.Worksheets("data")
k = data.UsedRange.Rows.Count
'find the last row before an empty record appears
For n = 1 To k
If Not IsEmpty(data.Cells(n, 1).Value) Then
count = n
ElseIf IsEmpty(data.Cells(n ,1).Value) Then
Exit For
End If
Next
'do the thing 9 times
For n = 1 To 9
If Not IsEmpty(data.Cells(n, 3).Value) Then
'cast the cell value to double and assign it to searchvalue
SearchValue = CDbl(data.Cells(n, 3).Value)
'i prefer to be extremely specific, but that's just me
Elseif IsEmpty(data.Cells(n, 3).Value) Then
MsgBox "No input found!", vbCritical
GoTo the_end
End If
'reset findarray to an empty collection
Set FindArray = New Collection
For i = 1 To count
'load your collection with the sample values casted to doubles
FindArray.Add CDbl(data.Cells(i, 1).Value)
Next
j = 1
Found = ""
For i = 1 To FindArray.Count
If FindArray(i) = SearchValue Then
If j = 1 Then
Found = i
ElseIf j > 1 Then
'im not sure what you're trying to accomplish with this line,
'so im just going to leave it as is and adjust it for my solution
'so it gives you the same output
Found = n & ", " & i
End If
j = j + 1
End If
Next
If Found = "" Then
MsgBox "Not found", vbCritical
Else
output.Add Found
End If
'i like to always just set the collection to nothing before a new iteration
Set FindArray = Nothing
Next
'dump all results in column 4
For i = 1 To output.Count
data.Cells(i, 4).Value = output(i)
Next
'garbage collection
Set FindArray = Nothing
Set output = Nothing
Set wb = Nothing
Set data = Nothing
the_end:
Exit Sub
I'm not entirely sure if this attempt at a solution will work for you, but I hope it's helpful in any way. Good luck!
Col A populated with values, Col C populated with search values to be found in Col A, Col D is where the row numbers of each value in Col C can be found.
The number of values in Col A and Col C are essentially limited only by the number of rows in your spreadsheet with no changes required to the code.
If you have not added a Dictionary reference, click on [Tools] at the top of the screen, click on [References...], scroll way down until you find [Microsoft Scripting Runtime], click the check mark next to that, then click [OK].
Sub FindAircraftHourly()
Dim dnySource As New Scripting.Dictionary
Dim strCellValue As String
Dim i0 As Long
With ActiveSheet
For i0 = 2 To .Rows.Count 'This starts at row 2 and goes to the end of the list. I'm assuming row 1 has a heading of some sort.
If Not IsEmpty(.Cells(i0, 1)) Then 'If the cell in col A of that row has a value, add that value to the dictionary as the key and the row number(s) as the items(s).
strCellValue = .Cells(i0, 1).Value
dnySource(strCellValue) = dnySource(strCellValue) & i0 & ", "
Else
Exit For 'Once you hit an empty cell, stop building the dictionary.
End If
Next i0
For i0 = 2 To .Rows.Count
If Not IsEmpty(.Cells(i0, 3)) Then 'If the cell in col C has a value then look through the dictionary to see if you have a list of row numbers to display.
strCellValue = .Cells(i0, 3).Value
If dnySource.Exists(strCellValue) Then 'If there is a list of row numbers for that value, display them in col D.
.Cells(i0, 4).Value = Left$(dnySource(strCellValue), Len(dnySource(strCellValue)) - 2) 'The - 2 here chops off the extra ", " at the end
Else 'Otherwise, indicate that the value in col C doesn't exist in col A.
.Cells(i0, 4).Value = "Value Not Found"
End If
Else
Exit For
End If
Next i0
End With
End Sub
Here's my attempt to solve your problem.
For questions just ask.
Option Explicit
Sub FindAircraftHourly()
Dim data As Worksheet
Dim searchrange As Range
Dim cell As Range
Dim findarray() As String
Dim searcharray() As Integer
Dim i As Integer
Set data = ThisWorkbook.Worksheets("data") 'the sheet your working on
Const maxinputvals As Integer = 3 'The number of search values you want to be looking for
ReDim searcharray(1 To maxinputvals) As Integer 'VBA doesn't need to start at 0
ReDim findarray(1 To maxinputvals) As String 'VBA doesn't need to start at 0
i = 0 'not needed but always nice to make sure
Do
i = i + 1 'add 1 to the count-var
If i > maxinputvals Then Exit Do 'if the count-var si bigger than max number of searchvalues quit the loop
If data.Cells(i, 3) <> "" Then 'check if cells is not empty
searcharray(i) = data.Cells(i, 3).Value 'safe the searchvalue
Else
MsgBox "Searchvalue #" & i & " is missing." 'exit the sub if a searchvalue is missing
Exit Sub
End If
Loop
Set searchrange = data.Range("A1:A5000")
For Each cell In searchrange 'go through the whole range
If cell.Value <> "" Then 'check is cell is empty
For i = 1 To maxinputvals 'if not, check if match with one of the searchvals
If cell.Value = searcharray(i) Then
findarray(i) = findarray(i) & ", " & cell.Row 'append your findarray string
End If
Next i
Else
Exit For 'if cell is empty exit the loop
End If
Next cell
For i = 1 To maxinputvals
findarray(i) = Mid(findarray(i), 3) 'delete the first ", "
data.Cells(i, 4) = findarray(i) 'output the findstring
Next i
End Sub
I have been working on a macro that summarizes the data from multiple sheets in my workbook. In order to know which columns to use in my summary sheet I need to first extract all the unique values from the first column in my sheets.
The idea is that it will loop through the sheets and define a range, then it will loop through each cell in the range, check if the value of that cell is already in the array and if not copy and paste it and add it to the array.
Unfortunately I get an the error "Index outside of valid Area" for the line that is supposed to add the cell value to the array.
ReDim Preserve uniqueVal(1 To UBound(uniqueVal) + 1) As Variant
I took that specific code from the question https://superuser.com/questions/808798/excel-vba-adding-an-element-to-the-end-of-an-array .
Here is the entire code for reference.
Private Sub CommandButton24_Click()
Dim xSheet As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim copyRng As Range
Dim destRng As Range
Dim cRange As Range
Dim c As Range
Dim uniqueVal() As Variant
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the summary worksheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a worksheet with the name "Summary"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary"
Set destRng = DestSh.Range("A1")
'Define inital array values
uniqueVal = Array("Account by Type", "Total")
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each xSheet In ActiveWorkbook.Worksheets
If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _
Set copyRng = xSheet.Range("A:A")
For Each c In copyRng.SpecialCells(xlCellTypeVisible)
If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _
'Copy to destination Range
c.Copy destRng
'move destination Range
Set destRng = destRng.Offset(0, 1)
'change / adjust the size of array
ReDim Preserve uniqueVal(1 To UBound(uniqueVal) + 1) As Variant
'add value on the end of the array
uniqueVal(UBound(uniqueVal)) = c.Value
End If
Next c
End If
Next xSheet
ExitTheSub:
Application.Goto DestSh.Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Per default, arrays in Excel VBA start with the index 0, not the index 1. You can test this by checking your arrays contents: your first string "Account by Type" should be on uniqueval(0) rather than on uniqueval(1).
Two ways to solve this:
add Option Base 1 to the top of your module or
change ReDim Preserve uniqueval(1 To UBound(uniqueval) + 1) to ReDim Preserve uniqueval(0 To UBound(uniqueval) + 1)
It's up to you which one you chose, but imo the latter is cleaner, since you don't have to fiddle with array options on module level.
As I see it, you're not actually using the arrays' contents yet. If you do later on, just loop For i = LBound(uniqueval) To UBound(uniqueval) - in which case it is irrelevant with what option you went.
On the first loop uniqueVal has no Ubound. That's why it fails. So, you should first Redim it as Redim uniqueVal(1 To 1), then write to the Ubound and increase the size thereafter. That would always leave you with a blank element at the top which you can remove at the end.
The better (because it runs faster) is to Dim uniqueVal to a possible max number, then set the current index with a counter, like i = i + 1, and do a Redim Preserve uniqueVal(i) at the end, thereby cutting off all unused elements.
The underscore at the end of a line of code means that the line is continued, logically, in the next line. For example,
If 1 <> 2 Then _
Debug.Print "All is well"
This is the same as If 1 <> 2 Then Debug.Print "All is well"
Observe, however, that there is no End If. If there were more than one command to follow the Then you must use End If, for example,
If 1 <> 2 Then
Debug.Print "All is well"
A = 3
End If
Here, everything between If and End If will only be executed if 1 <> 2. This is the case with If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _. Once the error of the UBound is cured this one will stop your code from running. Remove the underscore following the Then.
I have following Array which stores values found from a search function.
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
Array1(i) = FoundCell.Value 'Instead of .Value I can use .Row but .EntireRow doesn't work
i = i + 1
Next FoundCell
j = i - 1
i = 1
End If
I then extract data from the array using transpose which works for '.Value' and '.Row' but I can not extract the whole row from each found value by '.EntireRow'.
Range("A1:A" & UBound(Array1) + 1) = WorksheetFunction.Transpose(Array1)
I tried to change the range in several way's, but nothing seem to fit the .EntireRow criteria.
Update after comment from loannis:
How can I use EntireRow in my array to transpose all the rows to a target location based on the search results stored in FoundCell?
I am using the FindAll search function from cpearson http://www.cpearson.com/excel/findall.aspx
You can extract an entire row like this however it is a two dimensional array.
Sub MethodName()
Dim Array1
'Get all the cell values in row A
Array1 = Cells(1, 1).EntireRow
Dim i As Integer
'loop through the array and output the contents to the 2nd row
For i = 1 To UBound(Array1, 2)
Cells(2, i).Value = Array1(1, i)
Next i
End Sub
I came to the conclusion that for the purpose of which I am doing this for, I might as well scrap the array and do it like this:
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
FoundCell.EntireRow.Copy Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next FoundCell
End If
I'm trying to write a small macro to search a range of values (provided by an array full of user input) and, for the most part, return their current row. This range is a printable toolsheet of which I only need to print pages that I make changes too, therefore I am attempting to simplify my job by inputting the tools that have been updated, and having the macro tell me what pages to print.
I tried to make that as understandable as possibly, but let me know if clarification is needed.
The problem arises when I try to search the sheet using 'Application.WorksheetFunction'
Sub FunWithArrays()
Dim ToolNumber()
Dim i As Integer
i = 1
ReDim ToolNumber(1)
Do
ToolNumber(i) = InputBox("Please type the name of the tool with proper capitalization.", "Tool Number")
ReDim Preserve ToolNumber(UBound(ToolNumber) + 1)
i = i + 1
Loop Until ToolNumber(i - 1) = "Done"
MsgBox "Thank you for inputting the tool numbers.", vbOKOnly, "Input Complete"
Dim j As Integer
Dim ToolNoRow As Range
Dim PageNo As Double
For j = 1 To (i - 2)
ToolNoRow = Application.WorksheetFunction.Range("A:A").Text.Find(what:=ToolNumber(j), LookIn:=xlValues, lookat:=xlWhole)
PageNo = Application.WorksheetFunction.RoundUp((ToolNoRow / 1), 0)
MsgBox "Please print page " & PageNo
Next
End Sub
Any and all help is appreciated! Thank you!
I am not sure that I fully understand how you macro works, since it looks like you want to return row numbers but you talk about returning page numbers.
However, if you want to return the range of a cell in which a given input is found (since you have declared ToolNoRow As Range) you would do this by:
Set ToolNoRow = Worksheets("Sheet1").Range("A:A").Text.Find(what:=ToolNumber(j), LookIn:=xlValues, lookat:=xlWhole)
Note that you would have to state in what sheet you want to perform the search.
If you instead want to return the row in which this input is found, you could declare ToolNoRow as Long and then use:
ToolNoRow = Worksheets("Sheet1").Range("A:A").Text.Find(what:=ToolNumber(j), LookIn:=xlValues, lookat:=xlWhole).Row
You should probably include some error handling in your code, because Excel would return an error message whenever a search item is not found.
Try this
You may need to mod the logic after you get the cell address
Dim ToolNumber()
Dim i As Integer
i = 1
ReDim ToolNumber(1)
Do
ToolNumber(i) = InputBox("Please type the name of the tool with proper capitalization.", "Tool Number")
ReDim Preserve ToolNumber(UBound(ToolNumber) + 1)
i = i + 1
Loop Until ToolNumber(i - 1) = "Done"
MsgBox "Thank you for inputting the tool numbers.", vbOKOnly, "Input Complete"
Dim j As Integer
Dim ToolNoRow As Range
Dim PageNo As Double
For j = 1 To (i - 2)
With Range("A:A")
Set ToolNoCell = Find(what:=ToolNumber(j), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
'Do whatever Here
PageNo = Application.WorksheetFunction.RoundUp((ToolNoRow / 1), 0)
MsgBox "Please print page " & PageNo
Next