assigning priority based on user dynamically changing values excel vba - excel

I have list courses in cell b and their respective priorities in cell c from 1 to 49.
what I want is if a user changes any value of the priority column i.e. "C". then all other priority should be adjusted accordingly. logic can be seen in the attached sheet. the priority numbers should change dynamically as the user enters the value.
so in example one referring column L in the attached sheet.
if user change the no 4 priority to 8 then the rest will go one down .
similarly now we have got new nos list. so if any other number changes then it should adjust accordingly,keeping in mind the new list
sheet snapshot attached
Tried the below code but it always starts with the value 1 again. So the values are not adjusted based on new list.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myVal As Variant
Dim iCount As Long
Dim cell As Range
Dim myRange As Range
Set myRange = Worksheets("Sheet1").Range("C1:C49")
If Intersect(Target, Range("C1:C49")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
myVal = Target.Value
iCount = 1
For Each cell In myRange
If Intersect(Target, cell) Is Nothing Then
If iCount = myVal Then
iCount = iCount + 1
End If
cell.Value = iCount
iCount = iCount + 1
End If
Next cell
Application.EnableEvents = True
End Sub

Edited to work when first row is any row
The following was generated ...
from this code ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ExtVal As Variant, InsVal As Variant
Dim iLoop As Long
Dim InsRow As Long, ExtRow As Long
Dim foundArr() As Boolean
Dim myRange As Range
' initial settings
Set myRange = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim foundArr(1 To myRange.Rows.Count)
For iLoop = 1 To myRange.Rows.Count
foundArr(iLoop) = False
Next iLoop
If Intersect(Target, myRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
' calculate the extracted value - the user entered value
ExtVal = Target.Value
' calculate the inserted value - the number the user typed over
For iLoop = 1 To myRange.Rows.Count
foundArr(myRange.Cells(iLoop, 1).Value) = True
Next iLoop
For iLoop = 1 To myRange.Rows.Count
If Not foundArr(iLoop) Then
InsVal = iLoop
Exit For
End If
Next iLoop
' calculate the insertion row - the row the user typed in.
InsRow = CLng(Right(Target.Address, 1))
' calculate the extraction row - the original row of the number the user typed
ExtRow = 0
For iLoop = 1 To myRange.Rows.Count
If myRange.Cells(iLoop, 1).Value = ExtVal And myRange.Cells(iLoop, 1).Row <> InsRow Then
ExtRow = myRange.Cells(iLoop, 1).Row
Exit For
End If
Next iLoop
' do the swap / shuffle
Application.EnableEvents = False
For iLoop = myRange.Rows.Count To 1 Step -1
Debug.Print "Evaluating Row " & myRange.Cells(iLoop, 1).Row
If (myRange.Cells(iLoop, 1).Row <= ExtRow) Then
If myRange.Cells(iLoop, 1).Row > InsRow + 1 Then
myRange.Cells(iLoop, 1).Value = myRange.Cells(iLoop - 1, 1).Value
Else
If myRange.Cells(iLoop, 1).Row = InsRow + 1 Then
myRange.Cells(iLoop, 1).Value = InsVal
End If
End If
End If
Next iLoop
Application.EnableEvents = True
End Sub

Related

How to apply a condition to "used range" in whole column as a loop in excel using VBA?

I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub

Add or Delete Columns Based on Cell Value

I'm trying to add columns (or delete them if the number is reduced) between where "ID" and "Total" are based on the cell value in B1.
How could this be done automatically every time the cell is updated?
Code I have so far
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Dim i As Integer
For i = 1 To Range("B1").Value
Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
End If
End Sub
There are a number of issues in your code:
Unqualified range references refer to a default sheet object. While it won't be a problem in this instance (in a worksheet code behind module that object is sheet sheet containing the code, in any other module its the Activesheet), it's a bad habit to get into. Use the keyword Me to refer to the sheet the code is in.
When changing the sheet in a Worksheet_Change event, use Application.EnableEvents = False to prevent an event cascade (any time the code changes the sheet the event is called again)
Use an Error Handler to turn it back on (Application.EnableEvents = True)
Calculate how many columns to Insert or Delete based on existing columns
Range check the user input to ensure it's valid
Insert or delete in one block
On the assumption the "Totals" column contains a formula to sum the row (eg for 2 columns, row 4 it might be =Sum($C4:$D4), when you insert columns at column C the formula won't include the new columns. The code can update the formulas if required.
Target is already a range. No need to get its address as a string, then turn it back into a range, use it directly
Your code, refactored:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim NumColumnsRequired As Long
Dim NumExistingColumns As Long
Dim NumToInsertOrDelete As Long
Dim TotalsRange As Range
On Error GoTo EH
Set KeyCells = Me.Range("B1")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
' Validate Entry
If Not IsNumeric(KeyCells.Value) Then Exit Sub
NumColumnsRequired = KeyCells.Value
If NumColumnsRequired <= 0 Or NumColumnsRequired > 16380 Then Exit Sub
Application.EnableEvents = False
NumExistingColumns = Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column - 3
NumToInsertOrDelete = NumColumnsRequired - NumExistingColumns
Select Case NumToInsertOrDelete
Case Is < 0
' Delete columns
Me.Columns(3).Resize(, -NumToInsertOrDelete).Delete
Case Is > 0
' Insert columns
Me.Columns(3).Resize(, NumToInsertOrDelete).Insert CopyOrigin:=xlFormatFromLeftOrAbove
'Optional: update Total Formulas
Set TotalsRange = Me.Cells(Me.Rows.Count, Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column).End(xlUp)
If TotalsRange.Row > 3 Then
Set TotalsRange = Me.Range(TotalsRange, Me.Cells(4, TotalsRange.Column))
TotalsRange.Formula2R1C1 = "=Sum(RC3:RC" & TotalsRange.Column - 1 & ")"
End If
Case 0
' No Change
End Select
End If
EH:
Application.EnableEvents = True
End Sub
may try the code below to have the result like
code is more or less self explanatory
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total") 'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2 'Column A & B for Company and ID
Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol To LeftFixedCol + ColNum
Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
Columns(i).Delete
Next i
End If
End Sub
However to keep the Sum formula on total Column consistence with added column, may limit number of minimum columns to 2 and inserting columns in between existing columns, by changing following
If ColNum <= 1 Then Exit Sub
and
Columns(i - 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
also delete line inserting column heading
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
otherwise may add VBA code to change formula of total column to requirement.
You can try the following.
the named ranges are defined:
"B1" -> "ColumnNumber"
"B3" -> "Header.ID"
"F3" -> "Header.Total" (but it changes as you add / remove columns)"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim headerId As Range, headerTotal As Range, columnNumber As Range
Dim currentNumberOfColumns As Integer, targetNumberOfColumns As Integer
Dim columnsToAdd As Integer, columnsToRemove As Integer
Dim i As Integer
On Error GoTo error_catch
Application.EnableEvents = False
Set columnNumber = Me.Range("ColumnNumber")
If Not Application.Intersect(columnNumber, Target) Is Nothing Then
Set headerId = Me.Range("Header.ID")
Set headerTotal = Me.Range("Header.Total")
targetNumberOfColumns = columnNumber.Value
If targetNumberOfColumns <= 0 Then
Application.EnableEvents = True
Exit Sub
End If
currentNumberOfColumns = headerTotal.Column - headerId.Column - 1
Debug.Print "Currently there are " & currentNumberOfColumns & " columns"
If currentNumberOfColumns = targetNumberOfColumns Then
Application.EnableEvents = True
Exit Sub
Else
If targetNumberOfColumns > currentNumberOfColumns Then
columnsToAdd = targetNumberOfColumns - currentNumberOfColumns
Debug.Print "Need to add " & columnsToAdd & " columns"
For i = 1 To columnsToAdd
headerTotal.Offset(0, -1).EntireColumn.Select
Selection.Copy
headerTotal.EntireColumn.Select
Selection.Insert Shift:=xlToRight
Next i
Else
columnsToRemove = -(targetNumberOfColumns - currentNumberOfColumns)
Debug.Print "Need to remove " & columnsToRemove & " columns"
For i = 1 To columnsToRemove
headerTotal.Offset(0, -1).EntireColumn.Select
Selection.Delete Shift:=xlToLeft
Next i
End If
End If
End If
columnNumber.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
error_catch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub

Add/Delete Rows based on cell value

so I have an excel table with 2 columns: Times and Count, and 3 Rows: 1:00, 2:00 and 3:00 pm. I want functionality where when the user changes the count value for any of the rows, the count value minus 1 row should be added underneath. So for example for 1:00 pm below, when the user enters '4', it should add three rows below that row for a total of 4 rows. If the user changes the count to '2' it should remove 2 rows so that there are 2 total rows. This is what I have so far:
Times Count
1:00pm 4
2:00pm 0
3:00pm 0
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("C5:C100")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
'Save Workbook before so that original document will be saved
ActiveWorkbook.Save
Dim List As Long
Dim i As Long
Dim x As Long
Dim ExCnt As Variant
Dim aVal As Integer
'Find how many rows contain data
List = Range("B" & Rows.Count).End(xlUp).Row
For i = List To 2 Step -1
'Store exception value into variable
ExCnt = Range("C" & i).Value
With Range("C" & i)
'Insert rows unless text says Exception Count
If .Value > 1 And .Value <> "Exception Count" Then
.EntireRow.Copy
Application.EnableEvents = False
.Offset(1).EntireRow.Resize(.Value - 1).Insert
End If
CleanExit:
End With
Next i
Application.EnableEvents = True
End If
End Sub
This code adds the right amount of rows for each row but if the user changes the count value, the effect will compound for the existing rows.
I hope you appreciate how intricate this can actually be. :-)
Try this solution ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strKey As String, lngCount As Long, lngOffset As Long
Dim i As Long, rngNewRows As Range, lngTopRow As Long, lngBottomRow As Long
Dim bInBetween As Boolean
' Anymore than 10 cells and we'll skip this process.
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 2 Then
On Error Resume Next
Err.Clear
lngCount = Target.Value
On Error GoTo 0
If Err.Description = "" Then
If lngCount = 0 Then lngCount = 1
If lngCount > 0 Then
' Get the time value.
strKey = Target.Offset(0, -1).Text
bInBetween = False
' Check to make sure that the user isn't entering a value in between an already exploded set of rows.
If Target.Row > 1 Then
If Target.Offset(-1, -1).Text = strKey Then bInBetween = True
End If
If Not bInBetween Then
lngOffset = 0
' Now check each column below and delete or add rows depending on the count.
Do While True
lngOffset = lngOffset + 1
If Target.Offset(lngOffset, -1).Text <> strKey Then Exit Do
Loop
Application.EnableEvents = False
If lngOffset < lngCount Then
' We need to add rows.
Set rngNewRows = Target.Worksheet.Rows(Target.Offset(lngOffset, 0).Row & ":" & Target.Offset(lngOffset, 0).Offset(lngCount - lngOffset - 1, 0).Row)
lngTopRow = rngNewRows.Cells(1, 1).Row
lngBottomRow = rngNewRows.Cells(rngNewRows.Rows.Count, 1).Row
rngNewRows.Insert
For i = lngTopRow To lngBottomRow
Target.Worksheet.Cells(i, Target.Column - 1) = Target.Offset(0, -1).Value
Next
Else
If lngOffset <> lngCount Then
' We're over the count, determine the rows to delete.
Target.Worksheet.Rows(Target.Offset(lngCount, 0).Row & ":" & Target.Offset(lngOffset - 1, 0).Row).Delete
Else
' We have 1 row and that's all that's been asked for.
End If
End If
Application.EnableEvents = True
End If
End If
End If
End If
End Sub
... you clearly have some other rules that need to be applied but this should get you going. Check out the image below to see it in action.
A few points ...
It tries to cater for individuals entering values in column B within the exploded range and if they do that, it won't react to the value. Not sure if that's a requirement but I assumed it was.
0 will be treated as 1, so both 1, 0 and cleared will result in the resetting of the line.
Deletions happen at the bottom. So if the number goes from 10 to 3, it will delete the last set of rows to bring it back to 3.
It will only react to 1 cell at a time being changed. It reduced the complexity of the solution.
Outside of that, you're on your own. :-)

Speeding Up a Loop in VBA

I am trying to speed up a loop in VBA with over 25,000 line items
I have code that is stepping down through a spread sheet with over 25,000 lines in it. Right now the code loops thought each cell to see if the Previous cell values match the current cell values. If they do not match it inserts a new blank line. Right now the code take over 5 hours to complete on a pretty fast computer. Is there any way I can speed this up?
With ActiveSheet
BottomRow4 = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
Do
Cells(ActiveCell.Row, 5).Select
Do
ActiveCell.Offset(1, 0).Select
'Determines if previous cells is the same as current cells
Loop Until (ActiveCell.Offset(0, -1) & ActiveCell <>
ActiveCell.Offset(1, -1) & ActiveCell.Offset(1, 0))
'Insert Blank Row if previous cells do not match current cells...
Rows(ActiveCell.Offset(1, 0).Row & ":" & ActiveCell.Offset(1,
0).Row).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
BottomRow4 = BottomRow4 + 1
Loop Until ActiveCell.Row >= BottomRow4
Similarly to when deleting rows, you can save your inserts until you're done looping.
Run after selecting a cell at the top of the column you want to insert on (but not on row 1):
Sub Tester()
Dim c As Range, rngIns As Range, sht As Worksheet
Dim offSet As Long, cInsert As Range
Set sht = ActiveSheet
For Each c In sht.Range(Selection, _
sht.Cells(sht.Rows.Count, Selection.Column).End(xlUp)).Cells
offSet = IIf(offSet = 0, 1, 0) '<< toggle offset
If c.offSet(-1, 0).Value <> c.Value Then
'This is a workaround to prevent two adjacent cells from merging in
' the rngInsert range being built up...
Set cInsert = c.offSet(0, offSet)
If rngIns Is Nothing Then
Set rngIns = cInsert
Else
Set rngIns = Application.Union(cInsert, rngIns)
End If
End If
Next c
If Not rngIns Is Nothing Then
rngIns.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End Sub
Edit: runs in 3 secs on 25k rows populated using ="Val_" & ROUND(RAND()*1000), converted to values, then sorted.
Insert If Not Equal
Sub InsertIfNotEqual()
Const cSheet As Variant = 1 ' Worksheet Name/Index
Const cFirstR As Long = 5 ' First Row
Const cCol As Variant = "E" ' Last-Row-Column Letter/Number
Dim rng As Range ' Last Cell Range, Union Range
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Source Array Row Counter
Dim j As Long ' Target Array Row Counter
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Determine the last used cell in Last-Row-Column.
Set rng = .Columns(cCol).Find("*", , xlFormulas, , , xlPrevious)
' Copy Column Range to Source Array.
vntS = .Cells(cFirstR, cCol).Resize(rng.Row - cFirstR + 1)
End With
' In Arrays
' Resize 1D Target Array to the first dimension of 2D Source Array.
ReDim vntT(1 To UBound(vntS)) As Long
' Loop through rows of Source Array.
For i = 2 To UBound(vntS)
' Check if current value is equal to previous value.
If vntS(i, 1) <> vntS(i - 1, 1) Then
' Increase row of Target Array.
j = j + 1
' Write Source Range Next Row Number to Target Array.
vntT(j) = i + cFirstR
End If
Next
' If no non-equal data was found.
If j = 0 Then Exit Sub
' Resize Target Array to found "non-equal data count".
ReDim Preserve vntT(1 To j) As Long
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Set Union range to first cell of row in Target Array.
Set rng = .Cells(vntT(1), 2)
' Check if there are more rows in Target Array.
If UBound(vntT) > 1 Then
' Loop through the rest of the rows (other than 1) in Target Array.
For i = 2 To UBound(vntT)
' Add corresponding cells to Union Range. To prevent the
' creation of "consecutive" ranges by Union, the resulting
' cells to be added are alternating between column A and B
' (1 and 2) using the Mod operator against the Target Array
' Row Counter divided by 2.
Set rng = Union(rng, .Cells(vntT(i), 1 + i Mod 2))
Next
End If
' Insert blank rows in one go.
rng.EntireRow.Insert
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Edited: Added two options: didn't test for speed. I thought test2() would have been faster but I'm not certain depending on number of rows.
Untested, but just something I thought of quickly. If I'll remember I'll come back to this later because I think there are faster ways
Sub Test1()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then collectRows.Add rowNext
Next rowNext
For rowNext = 1 To collectRows.Count
wsSheet.Cells(collectRows(rowNext), 1).EntireRow.Insert
Next rowNext
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Second Option inserting all at once:
I used a string here because union would change rows next to each other into one larger range. Instead of Range("1:1", "2:2") it would create ("1:2") and that won't insert the way you need. I don't know of a cleaner way, but there probably is.
Sub Test2()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Dim strRange As String
Dim cntRanges As Integer
Dim rngAdd As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then
strRange = wsSheet.Cells(rowNext, 1).EntireRow.Address & "," & strRange
cntRanges = cntRanges + 1
If cntRanges > 10 Then
collectRows.Add Left(strRange, Len(strRange) - 1)
strRange = vbNullString
cntRanges = 0
End If
End If
Next rowNext
If collectRows.Count > 0 Then
Dim i As Long
For i = 1 To collectRows.Count
Set rngAdd = Range(collectRows(i))
rngAdd.Insert
Next i
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Moving through sequential array items

The code below creates an array of unique values from values in Column A. Each selected array element is used to select a range on the sheet. The range is displayed in a userform Listbox.
I would like help with code that would allow the user to scroll through each array ‘MyarUniqVal’ element via two form buttons Right ‘>>’ and Left ‘<<’. Each time a button is pressed a sequential array item will be selected and a new range will populate the Listbox.
Any help would be greatly appreciated.
Thanks,
Please see the code below:
Sub testRange3()
Dim lastrow, i, j As Long
Dim c As Range, rng As Range
Dim MyArUniqVal() As Variant
ReDim MyArUniqVal(0)
'With ActiveSheet
With ThisWorkbook.Worksheets("Temp")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
MyArUniqVal(UBound(MyArUniqVal)) = .Cells(i, 1).Value
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) + 1)
End If
Next
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) - 1)
End With
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
'Prints out each array to Immediate Window
Debug.Print j
'Prints out unique values from Column A stored in array to Immediate Window
Debug.Print MyArUniqVal(j)
Next
With ThisWorkbook.Worksheets("Temp")
'changed to ActiveSheet
'With ActiveSheet
For Each c In .Range("A1:A" & lastrow)
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
If UCase(c.Text) = j Then
'If UCase(c.Text) = "B" Then
If rng Is Nothing Then
Set rng = .Range("B" & c.Row).Resize(, 2)
Debug.Print rng
Else
Set rng = Union(rng, .Range("B" & c.Row).Resize(, 2))
Exit For
Debug.Print rng
End If
End If
Next
Next c
End With
If Not rng Is Nothing Then rng.Select
End Sub
See the following code to get you heading the the right direction. I took the approach of adding another listbox that displayed the available prefixes to help the user see what was available and then searching the data column for entries containing the selected prefix.
Hopefully you will be able to adapt the name of the variables and objects to whatever you are currently using. Let me know if anything needs clarification. Best of luck with your project.
My sample form code:
Private Sub cmdBack_Click()
code_frmMain.IncrementValue (0)
End Sub
Private Sub cmdNext_Click()
code_frmMain.IncrementValue (1)
End Sub
Private Sub lstPrefixes_Change()
code_frmMain.DisplayNext
End Sub
Private Sub UserForm_Initialize()
code_frmMain.testRange3
End Sub
My sample program code:
' This subroutine will search column B for the selected value
Sub DisplayNext()
Dim searchTerm As String
Dim lastRow As Long
Dim i As Integer
' clear frmMain.lstResults
frmMain.lstResults.Clear
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
searchTerm = frmMain.lstPrefixes.List(i)
Exit For ' exits once selected item is found
End If
Next i
'Debug.Print searchTerm
With Sheets("Temp")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
For i = 1 To lastRow
If InStr(Cells(i, 2).Value, searchTerm) Then
frmMain.lstResults.AddItem (Cells(i, 2).Value)
End If
Next i
End Sub
' increments value. input direction: 0 is down and 1 is up
Sub IncrementValue(direction As Integer)
Dim currentIndex As Integer
currentIndex = -1
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
currentIndex = frmMain.lstPrefixes.ListIndex
Exit For ' exits once selected item is found
End If
Next i
' defaults to first item if none selected
If currentIndex = -1 Then
frmMain.lstPrefixes.Selected(0) = True
currentIndex = 0
End If
If direction = 0 Then
' prevents listIndex from being invalid
If currentIndex = 0 Then
frmMain.lstPrefixes.Selected(frmMain.lstPrefixes.ListCount - 1) = True
Else
frmMain.lstPrefixes.Selected(currentIndex - 1) = True
End If
Else
If currentIndex = frmMain.lstPrefixes.ListCount - 1 Then
frmMain.lstPrefixes.Selected(0) = True
Else
frmMain.lstPrefixes.Selected(currentIndex + 1) = True
End If
End If
End Sub
Note that I also added this to the bottom of your testRange3() to use that data that you had already gathered:
For i = 0 To UBound(MyArUniqVal)
frmMain.lstPrefixes.AddItem (MyArUniqVal(i))
Next i
Sample Data:
Running on user form:

Resources