i foung similiar topic, but i can t apply completily that solution to my needs... I want to upgrade excel workbook at my job by making it more auto-entry capable.
Mostly i use excel functions, but sometimes i need some VBA coding, which im not very familiar with. So my problem is, that i need something like this mentioned on this thread. How to get the first and last numbers in a sequence
I have box numbers in different sequince in ascening order starting from "A4" to X on
Sheet1. Example Box numbers: M004935149,M004935150,M004935151,M004935202,M004935203,M004935204,M004935205, is it possible when i copy&paste(values) to sheet2 from "A4" to X (depenting on number of boxes copied) to make a string, sentence or whatever is called in specific form in some other cells. M004935149-151 // M004935202-205. I used code from topic in link above, it can make half job done but i can t figure it out how to make entry from desired cell range and display them on worksheet, and to display values in desired format. Link of screen shoots from my example is following:
I hope that someone can help. Thanks in advance.
Check this
Option Explicit
Sub test2()
Dim ws As Worksheet
Dim arr() As String, result As String, letter As String, cellValue As String, tempLastElement As String
Dim lastColumn As Long, counter As Long
Dim firstColumn As Integer, targetRow As Integer, i As Integer
Set ws = Worksheets("Sheet1")
firstColumn = 1 'number of first column with target data
targetRow = 1 'number of row with target data
lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
ReDim arr(1 To lastColumn - firstColumn + 1)
letter = Left(ws.Cells(targetRow, firstColumn).Value, 1) 'if count of character in start of string will be more 1, replace 1 on to count of characters
For i = 1 To UBound(arr)
cellValue = ws.Cells(targetRow, i).Value
arr(i) = Right(cellValue, Len(cellValue) - 1) 'if count of character in start of string will be more 1, replace 1 on to count of characters
Next i
ReDim sequenceArr(1 To UBound(arr))
sequenceArr(1) = arr(1)
counter = 2
For i = 1 To UBound(arr) - 1
If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then
tempLastElement = arr(i + 1)
sequenceArr(counter) = tempLastElement
Else
counter = counter + 1
sequenceArr(counter) = arr(i + 1)
counter = counter + 1
End If
Next
ReDim Preserve sequenceArr(1 To counter)
result = ""
counter = 1
For i = 1 To UBound(sequenceArr) - 1
If counter > UBound(sequenceArr) Then Exit For
If result = "" Then
result = letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
Else
result = result & "//" & letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
End If
Next
ws.Range("D4").Value = result
End Sub
Result on
I'm relatively new to VBA
I think the error is in my syntax.
Bellow is a sub routine im working on. the array "MyArray" is always empty. I've dim'd and redim'd and changed the type and the syntax based on what I've seen online a million times its either always 0 or empty. please help.
Sub CostPerTon()
Dim FeedType As String, count#, CostPerTon#
FeedType = "Duck - Comercial - Starter - 1 to 25 Days"
Sheets("Formulations").Activate
count = Application.WorksheetFunction.CountA(Range("A:A"))
i = 1
Dim IngredientCost As Double
Dim MyArray(100) As Variant
Do While i < count + 1
IngredientCost = Application.WorksheetFunction.VLookup(FeedType, Range("1:1048576"), i + 2, 0) _
* Worksheets("Costs").Cells(i + 2, 2) * (1 / 1000)
MyArray(i) = IngredientCost
i = i + 1
Loop
End Sub
the variable "IngredientCost" has values when I cycle through the loop so that function is fine. It breaks down at the MyArray(i)=IngredientCost line. it just stays empty
and the count is 14
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 ran into the following issue when dealing with adding to variable array sizes. The loop runs one time more then it should essentially. But I'm curious as to what would cause this behavior? Am I not quite understanding how the loop exit functions are being called?
Here's the code:
Module Module1
Sub Main()
Dim num(-1)
Dim i = 0
Console.WriteLine("Input numbers to be added, q to stop:")
Dim input
Dim total = 0
Do
ReDim Preserve num(UBound(num) + 1) : num(UBound(num)) = i 'resize the array each time before an element is added.
input = Console.ReadLine
If IsNumeric(input) Then 'attempt to break loop on non numeric input
num(i) = CInt(input)
i += 1
Else
Exit Do
End If
Loop
total = 0
For Each n In num
total += n
Next
Console.WriteLine(Join(num))
Console.WriteLine("Total: " & total)
Console.ReadLine()
For input: 1 2 3 4 5 q, the output I get is:
1 2 3 4 5 5
Total: 20
It adds the last element twice, which is interesting as it is not only running twice but somehow using the last numeric input even though the final input was not numeric. Does anyone know why that would be?
You both (jnb92, PankajJaju) should not grow the array before you are sure the input is numerical and has to be stored.
Dim input
Do
input = Console.ReadLine()
If IsNumeric(input) Then 'attempt to break loop on non numeric input
ReDim Preserve num(UBound(num) + 1)
num(UBound(num)) = CInt(input)
Else
Exit Do
End If
Loop
Update wrt comment:
Your
ReDim Preserve num(UBound(num) + 1) : num(UBound(num)) = i
assigns i to num for each input; your
num(i) = CInt(input)
overwrites that with your numerical input, but not for the terminating "q". So for your (one and only?) test case, the spurious last elemement is (accidentially) 5.
I've used your script and tried to create a working solution
Dim num, input, total, i
num = Array()
i = 0
Do
input = Inputbox("Input numbers to be added, q to stop:")
If IsNumeric(input) Then 'attempt to break loop on non numeric input
ReDim Preserve num(UBound(num) + 1) 'resize the array each time before an element is added.
num(i) = CInt(input)
i = i + 1
Else
Exit Do
End If
Loop
total = 0
For Each n In num
total = total + n
Next
msgbox Join(num)
msgbox "Total: " & total
Edit - Updated answer based on #Ekkehard.Horner comments
I would like to be able to add some range of data in a dynamic multidimensional array without using a double loop that screens each element of the array. But I don't know if it is possible. By double loop, I mean such a code (this is only an example):
Dim Films(1 To 5, 1 To 2) As String
Dim i As Integer, j As Integer
For i = 1 To 5
For j = 1 To 2
Films(i, j) = Cells(i, j).Value
Next j
Next i
I am using VBA 2010. I know how many rows my array has, but the number of columns is variable.
Here is my code :
Sub DRS(Item)
'item is a name to search for in a specific range
Dim SrcRange() As Variant
Dim cell3 As Range
Dim n As Integer, m As Integer
SrcRange() = Array()
ReDim SrcRange(45, 0)
m = -1
n = 0
With Sheets("X")
For Each cell3 In .Range("I13:AG" & .Cells(1, Columns.Count).End(xlToRight).Column)
'the range ("I13:AG...") contains names, and some will match with "item"
m = m + 1
If Len(cell3.Value) > 0 And cell3 = Item Then
SrcRange(0, n) = .Range(m + 8 & "30:" & m + 8 & "75")
'the previous line **should** add a whole range of cells (which contain numbers, one by cell) in a colum of the array, but this is the line that doesn't work.
n = n + 1
ReDim Preserve SrcRange(UBound(SrcRange), n)
End If
Next cell3
End With
End Sub
I already tried those::
SrcRange(:, n) = .Range(m + 8 & "30:" & m + 8 & "75")
SrcRange(0:45, n) = .Range(m + 8 & "30:" & m + 8 & "75")
SrcRange(, n) = .Range(m + 8 & "30:" & m + 8 & "75")
but no one worked.
Is there a way or a formula that would allow me to add a full range of cells to each column of the array, or am I obliged to use a double loop to add the elements one by one?
I'm guessing that this Range...
.Range("I13:AG" & .Cells(1, Columns.Count).End(xlToRight).Column)
...should actually be xlToLeft instead of xlToRight (xlToRight will always return I13:AG16384).
I'm also not entirely sure what the m + 8 & "30:" & m + 8 & "75" is supposed to be evaluating to, because you increment the variable m each time through the loop, and it gives you ranges like 930:975. I'll take a stab in the dark and assume that the m + 8 is supposed to be the column that you found the item in.
That said, the .Value property of a Range object will just give you a 2 dimensional array. There isn't really any reason to build an array - just build a range and then worry about getting the array out of it when you're done. To consolidate the range (you only get the first area if you grab its Value), just copy and paste it to a temporary Worksheet, grab the array, then delete the new sheet.
Sub DRS(Item)
'item is a name to search for in a specific range
Dim SrcRange() As Variant
Dim found As Range
Dim cell3 As Range
With Sheets("X")
For Each cell3 In .Range("I13:AG" & .Cells(1, Columns.Count).End(xlToLeft).Column)
'the range ("I13:AG...") contains names, and some will match with "item"
If Len(cell3.Value) > 0 And cell3.Value = Item Then
If Not found Is Nothing Then
Set found = Union(.Range(.Cells(30, cell3.Column), .Cells(75, cell3.Column)), found)
Else
Set found = .Range(.Cells(30, cell3.Column), .Cells(75, cell3.Column))
End If
End If
Next cell3
End With
If Not found Is Nothing Then
Dim temp_sheet As Worksheet
Set temp_sheet = ActiveWorkbook.Sheets.Add
found.Copy
temp_sheet.Paste
SrcRange = temp_sheet.UsedRange.Value
Application.DisplayAlerts = False
temp_sheet.Delete
Application.DisplayAlerts = True
End If
End Sub