Firstly, I would like to thank you in advance for all the answers.
I've got an "end" array which contains row numbers.
If OptionButton1 = True Then
Dim arraydodrukowania() As String
ReDim arraydodrukowania(1 To o, 1 To 2)
For j = LBound(array1) To UBound(array1)
If array1(j, 9) = 1 And array1(j, 8) = ComboBox2.Value Then
arraydodrukowania(j, 1) = array1(j, 9)
arraydodrukowania(j, 2) = array1(j, 2)
Else
End If
what I want to do is to select all rows defined by array values
I know that the selection method should be avoided, but it can not be omitted at this occasion.
So, in other words, I need a code which will loop trough the array and will add row no defined by the value in the array to selection.
The result would be (for example) row no. 2, 5, 1456, 2354 are selected.
the problem here is that the number of rows that needs to be selected varies.
So
For j = LBound(array1) To UBound(array1)
array1(j,1).<ADD TO SELECTION>
next j
Any ideas?
Related
If i have this code is there a simple way to add item1 to the beginning of the array and item2 to the end of the array in VBA?
The below code currently runs.
Dim nameArray as variant
Dim k as integer
Dim item1 as string
Dim item2 as string
k = 1
nameArray = Range(Cells(2, 3), Cells(5, 3)).Value
For Each i In nameArray
newcol = baseclmn + k
tblComp.ListColumns.Add(newcol).Name = i
k = k + 1
Next I
Thanks for any help you can offer
You could start off with a larger array and replace the first and last items.
Dim nameArray as variant
nameArray = Range(Cells(1, 3), Cells(6, 3)).Value
nameArray(LBound(nameArray), 1) = "Item1"
nameArray(UBound(nameArray), 1) = "Item2"
If you want to expand the array, perhaps something like this:
nameArray = Range(Cells(2, 3), Cells(5, 3)).Value
Dim newArray
ReDim newArray(1 to Ubound(nameArray, 1) + 2, 1 to Ubound(nameArray, 2)) 'add two rows
newArray(1, 1) = "item1"
newArray(Ubound(newArray, 1), 1) = "item2"
Dim i As Long
For i = LBound(nameArray, 1) To Ubound(nameArray, 1)
newArray(i + 1, 1) = nameArray(i, 1)
Next
Explanation:
nameArray is a 2-dimensional array, where the first dimension corresponds to rows and the second to columns. Note that this array is one-based, i.e. the first index is 1 and not 0.
The code uses ReDim to create a new array, containing
Two more rows than nameArray
The same number of columns as nameArray.
Then it adds the first and last items:
newArray(1, 1) = "item1": 1, 1 corresponds to the first row, first column.
newArray(Ubound(newArray, 1), 1) = "item2": Ubound(newArray, 1) corresponds to the last row, and 1 again corresponds to the first column.
Finally it uses a loop to read the items from nameArray into the middle of newArray.
Further helpful reading includes Arrays and Ranges in VBA.
You can enlarge (and/or restructure) the existing (vertical) nameArray in one go
via an undocumented feature of Application.Index()
using either the new Sequence() function (available since MS 365!) or a workaround via row evaluation (commented out in comment)
to pass a whole array(!) of row numbers (rowArr) as argument (instead of a single row index):
newArray = Application.Index(nameArray, rowArr, 1)
where rowArr is a vertical array of sequential row numbers reflecting the currently existing indices, and 1 the unchanged column index.
Sub TopBottomAdditions()
'0. define 1-based 2-dim data field
Dim nameArray
nameArray = Sheet1.Range(Cells(2, 3), Cells(5, 3)).Value 'i.e. data field of cells C2:C5
'1a create a sequence (array) ranging from 0 to elements count plus +1 (2 new elems)
Dim rowArr ' {0,1,2,..n,n+1}
rowArr = WorksheetFunction.Sequence(UBound(nameArray) + 2, 1, 0)
''>workaround if you don't dispose of version MS 365
' rowArr = Evaluate("row(1:" & UBound(nameArray) + 2 & ")-1")
'1b keep existing values in rows 1..n and add top+bottom element
'note: index 0 fetches element of existing index 1, n+1 gets a temporary error value
Dim newArray
newArray = Application.Index(nameArray, rowArr, 1)
'1c insert new top & bottom values
newArray(1, 1) = "Top value" ' overwrites New elem no 1
newArray(UBound(newArray), 1) = "Bottom value" ' writes New last elem
End Sub
Syntax of Sequence()
=SEQUENCE(rows,[columns],[start],[step])
I am attempting to create an Auto-grading test of sorts in Excel.
I have 5 values in Sheet1 that are input by a user in cells E5:E9. These should then be compared against a range of 5 more cells in Sheet2 (also cells E5:E9).
As the user might not always list these entries in the same order that I have in my Sheet2 range, I decided that I should loop through the range for each cell's input.
The next step would be to be able to ignore the value in the range once a match has been found but I need to get this part working correctly. Currently, the values absolutely match. However, I am not getting the correct output.
Sub Q1()
Dim i As Integer
For i = 5 To 9
If (Sheet1.Cells(5, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(6, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(7, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(8, 5) = Sheet2.Cells(i, 5)) And (Sheet1.Cells(9, 5) = Sheet2.Cells(i, 5)) Then
Sheet1.Cells(5, 6) = 1
Exit For
Else
Sheet1.Cells(5, 6) = 0
End If
Next
End Sub
I would expect the output of 1 to Sheet1 cell E6 but I am currently getting 0. Thanks!
Little Complex :)
Sub Q1()
Dim i As Integer
Dim j As Integer
Dim chck(5 To 9) As Boolean
For i = 5 To 9
For j = 5 To 9
If Sheet1.Cells(i, 5) = Sheet2.Cells(j, 5) Then
chck(i) = True
Exit For
Else: chck(i) = False
End If
Next
Next
j = 0
For i = LBound(chck) To UBound(chck)
If chck(i) = True Then j = j + 1
Next
If j = 5 Then
Sheet1.Cells(5, 6) = 1
Else: Sheet1.Cells(5, 6) = 0
End If
End Sub
Does this really need to be VBA? A formula can perform this calculation. Use this in 'Sheet1' cell F5:
=--(SUMPRODUCT(COUNTIF(Sheet2!E5:E9,E5:E9))>0)
If at least one of the values in 'Sheet1'!E5:E9 (the user entered values) exists in your 'Sheet2'!E5:E9 list, the formula will return a 1 else 0 which is the desired result based on your description.
I'm a beginner at using visual basic, and I've run into a little problem. What I want to do is take an excel spreadsheet and search through a specific column in order to find a name, then grab everything in that row in order to transfer it over to another sheet. I've got everything running except that I run into an endless loop for a reason I do not understand.
'set up a for loop that increments through all sheets in the workbook
For i = 1 To ThisWorkbook.Sheets.Count
'set up a temp page to work with the current page
Set tem = ThisWorkbook.Sheets(i)
'increment through all the rows that have data in them
For Each rng In tem.Rows
'if the data matches what was searched for, copy it into another worksheet
If tem.Cells(ct, 4) = SForm.Text Then
sr.Cells(spot, 1) = tem.Cells(ct, 1)
sr.Cells(spot, 2) = tem.Cells(ct, 2)
sr.Cells(spot, 3) = tem.Cells(ct, 3)
sr.Cells(spot, 4) = tem.Cells(ct, 4)
sr.Cells(spot, 5) = tem.Cells(ct, 5)
sr.Cells(spot, 6) = tem.Cells(ct, 6)
sr.Cells(spot, 7) = tem.Cells(ct, 7)
sr.Cells(spot, 8) = tem.Cells(ct, 8)
sr.Cells(spot, 9) = tem.Cells(ct, 9)
sr.Cells(spot, 10) = tem.Cells(ct, 10)
sr.Cells(spot, 11) = tem.Cells(ct, 11)
sr.Cells(spot, 12) = tem.Cells(ct, 12)
'increment the placeholder for the new sheet
spot = spot + 1
End If
'increase ct to keep track of where in the worksheet it is
ct = ct + 1
Next rng
'reset ct for the next worksheet
ct = 1
Next i
The Specific issue I run into, is an overflow because ct is an int and maxes out. which tells me I have an endless loop on my hands.
Thanks for the help in advance.
You are iterating over 1 million times per sheet, this is going to take a while. Find the last cell in column D and only iterate through those rows
Plus you do not need ct. instead use rng.row in its place.
Then combine the whole value assignation into one line.
For i = 1 To ThisWorkbook.Sheets.Count
'set up a temp page to work with the current page
Set tem = ThisWorkbook.Sheets(i)
'increment through all the rows that have data in them
For Each rng In tem.Range("D1", tem.Cells(tem.Rows.Count, 4).End(xlUp))
'if the data matches what was searched for, copy it into another worksheet
If rng.Value = SForm.Text Then
sr.Range(sr.Cells(spot, 1), sr.Cells(spot, 12)).Value = tem.Range(tem.Cells(rng.Row, 1), tem.Cells(rng.Row, 12)).Value
'increment the placeholder for the new sheet
spot = spot + 1
End If
Next rng
Next i
To make it even quicker look into dropping the whole range into an array and output into another array to minimize the interaction between the sheets and vba.
My code need more than one hours to complete for 3500 rows but I need to work for more than 40000 rows data.
I am looking for alternatives to my code by using dictionary, with improved performance within the context of interest.
Could anyone help me?
Sub StripRow2Node()
'Read the Strip Design table
With Sheets("Design-Moment")
Sheets("Design-Moment").Activate
LastR1 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
DM_arr = .Range(Cells(1, 1), Cells(LastR1, 7)) 'Col 1 to Col 7
DM_count = UBound(DM_arr, 1)
End With
'Read the x and y coordinations and thickness of a node in node design
With Sheets("Design-Shear")
Sheets("Design-Shear").Activate
LastR2 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
DS_arr = .Range(Cells(1, 4), Cells(LastR2, 5)) 'Col 4 to Col 5
SX_arr = .Range(Cells(1, 26), Cells(LastR2, 27))
SY_arr = .Range(Cells(1, 30), Cells(LastR2, 31))
DS_count = UBound(DS_arr, 1)
End With
'** Find correponding reference row in Design-Moment for nodes**
'Match node to striip station and output row index
For i = 5 To DS_count
XStrip = SX_arr(i, 1)
XStation = DS_arr(i, 1)
YStrip = SY_arr(i, 1)
YStation = DS_arr(i, 2)
For j = 5 To DM_count
If DM_arr(j, 1) = XStrip Then 'X-Strip Name is matched
If DM_arr(j, 4) >= XStation And DM_arr(j - 1, 4) < XStation Then
SX_arr(i, 2) = j 'matched row reference for X-strip
End If
End If
If DM_arr(j, 1) = YStrip Then
If DM_arr(j, 5) <= YStation And DM_arr(j - 1, 5) > YStation Then
SY_arr(i, 2) = j
End If
End If
Next j
Next i
'Write the matched strip information to node
For i = 5 To LastR2
With Sheets("Design-Shear")
.Cells(i, 27) = SX_arr(i, 2)
.Cells(i, 31) = SY_arr(i, 2)
End With
Next i
End Sub
I suspect that almost all the time is being used writing back cell-by-cell to the sheet here:
'Write the matched strip information to node
For i = 5 To LastR2
With Sheets("Design-Shear")
.Cells(i, 27) = SX_arr(i, 2)
.Cells(i, 31) = SY_arr(i, 2)
End With
Next i
Writing back to Excel is much slower than reading from Excel.
I would suggest switching off screen updating and calculation, accumulating the results (currently X_arr(i, 2) and SY_arr(i, 2)) in separate arrays and then writing the arrays back to a range in a single operation rather than cell-by-cell
There are several points to improve:
1. Use qualified references to avoid.activate statements
You start off nicely with
With Sheets("Design-Shear")
...
DS_arr = .Range(Cells(1, 4), Cells(LastR2, 5)) 'Col 4 to Col 5
but fail to make the Cells objects refer to the With block. Instead use
With Sheets("Design-Shear")
...
DS_arr = .Range(.Cells(1, 4), .Cells(LastR2, 5)) 'Col 4 to Col 5
Now you do not have to activate the sheet anymore.
From the code I have to assume that there is only one possible match returned in this statement:
SX_arr(i, 2) = j
for all i; otherwise, the second, third...occurrence would overwrite this value of j. If that is indeed the case you can stop looping over j once a match is found:
SX_arr(i, 2) = j 'matched row reference for X-strip
Exit For
Shortcut both If statements if DM_arr(j, 1) can match XStrip or YStrip. If these matches are mutually exclusive, use ElseIf instead of If for the second statement.
Shortcutting the j-loop should improve the runtime noticeably. Of course, if you need the last matching index (instead of the first) then this will not apply.
edit:
For a dictionary solution, see for instance the excellent code from Jeeped here: https://codereview.stackexchange.com/questions/133664/searching-values-of-range-x-in-range-y
The code I have once worked to add/delete groups of rows (requirements). I needed to modify the code so that if the 1st row of the group met certain criteria (i.e, the requirement was not one we wanted to consider), (1) we would not count it and (2), we would hide the group (current and subsequent 2 rows). This all works fine.
The problem is that now that I incorporated these changes, I get an error in another section of the code and for the life of me I cannot figure out why. I have stepped through this and am extremely frustrated. I am reaching out for help, and am hoping someone can see my error(!)
We calculate the start and finish row numbers within a grouping, and store these calculations in Arrays called "Start" and "Finish." I use the ReDim statement to initialize my arrays, because I thought that could be part of the problem, but no.
Any insight as to why my "subscripts are out of range" would be appreciated. I have traced through the logic, investigated this error, and read about the syntax/usage of VBA arrays. I don't know what else to do. Thanks in advance. Here are the relevant lines:
Sub Button1_Click()
Cells.Select
Selection.ClearOutline
If Cells.EntireRow.Hidden Then Cells.EntireRow.Hidden = False
Dim Start() As Integer
Dim Finish() As Integer
Dim p As Integer, q As Integer
ReDim Start(0, 50)
ReDim Finish(0, 50)
The following is embedded in logic that loops through all the rows in the spreadsheet:
i = 1
For Row = 4 To Cells(1, 6).Value - 1
If Begin Then
If Cells(Row, 3).Interior.ColorIndex = 44 Then
Start(i) = Row + 1
j = Cells(Row, 2).Value
Begin = False
End If
Else
If Cells(Row, 2).Value = j + 1 Or Cells(Row, 2).Interior.ColorIndex = 37 Then
Finish(i) = Row - 1
Begin = True
i = i + 1
Row = Row - 1
End If
End If
Next
The block I changed is as follows (code I added is last block where I attempt to hide rows). It precedes the previous. I am wondering how my change could have affect the above(?!)
If Cells(Row, 5).Value = "Requirement" Then
Range(Cells(Row, 4), Cells(Row, 4)).Interior.ColorIndex = 40
Rows(Row).Font.Bold = True
Rows(Row).Font.Italic = False
Rows(Row).Font.ColorIndex = 1 'Black
If Cells(Row - 3, 4).Value = "" Then 'this is requirement #1
Cells(Row, 4).Value = 1
Else
Cells(Row, 4).Value = Cells(Row - 3, 4).Value + 1
End If
p = Row
q = p + 2
Rows(p & ":" & q).Select
If Cells(p, 19).Value = "4" Then
Selection.EntireRow.Hidden = True
Else
Selection.EntireRow.Hidden = False
End If
Redim Start(0,50) makes the array dimensions 0 to 0, 0 to 50 i.e. a 2d array.
This means that when you call the array you need to provide parameters for both dimensions I.E: Start(0,i) or Finish(0,i). Calling Start(i) will result in the error you mentioned.
The easiest way to get rid of the error is to change your Redim lines to
ReDim Start(50)
ReDim Finish(50)
which is what I assume you meant to do in the first place.
Note: Based upon the format you used, you may have been meaning to do Start(0 to 50) and Finish(0 to 50) initially. The comma in the dimensioning indicates another dimension instead of a separation between lower and upper bounds.