I need to traverse a range from the bottom of the spreadsheet to the top of the spreadsheet. The range can be discontinuous, but I have removed overlaps (I'm only concerned with the row order, so I've also reduced the column to "A") and placed the range in "Overall_Range". Since the areas can come into the range in any order, I've built a function, Get_Loop_Order, that returns an array with order in which the areas should be processed to go from bottom to top. My plan was to just iterate over each area (from bottom to top) like this:
Loop_Order = Get_Loop_Order(Overall_Range)
For A = LBound(Loop_Order) To UBound(Loop_Order)
For Each this_row In Overall_Range.Areas(Loop_Order(A)).Rows
... do stuff ...
Next this_row
Next A
I realized that the For Each on Range.Rows will not be processed in reverse order (in fact, I have no guarantee of the order at all as far as I know).
Does anyone know if there is a way to loop through a range that is guaranteed to occur in a specific row order? When I select (the use of the word "select" here should not be confused with the Excel VBA term "Selection," the code above uses "Overall_Range") a range from bottom to top (A10:A2) the loop is in that order, when I select a range from top to bottom (A2:A10) it is in that order. I have no idea what happens if I do something like Union(A10:A2, A1:A2). I'm thinking that I will have to write another function that returns an array with the order to process things, but I'd love it if someone else had another solution. Can you help?
UPDATE:
I did some more testing Here is the code:
Dim my_range As Range 'Range being tested
Dim N As Long 'Loop variable when numbers are needed
Dim M As Range 'Loop variable when ranges are needed
Set my_range = ActiveSheet.Range("A2:A10")
ActiveSheet.Range("B1").Value = "A2:A10"
ActiveSheet.Range("B1").Font.Bold = True
ActiveSheet.Range("B1").HorizontalAlignment = xlCenter
ActiveSheet.Range("B1:C1").Merge
ActiveSheet.Range("B2").Value = "Row Index"
ActiveSheet.Range("B2").Font.Bold = True
ActiveSheet.Range("B2").HorizontalAlignment = xlCenter
ActiveSheet.Range("C2").Value = "Row Iterator"
ActiveSheet.Range("C2").Font.Bold = True
ActiveSheet.Range("C2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("B" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("C" & N + 2).Value = M.Row
N = N + 1
Next M
Set my_range = ActiveSheet.Range("A10:A2")
ActiveSheet.Range("D1").Value = "A10:A2"
ActiveSheet.Range("D1").Font.Bold = True
ActiveSheet.Range("D1").HorizontalAlignment = xlCenter
ActiveSheet.Range("D1:E1").Merge
ActiveSheet.Range("D2").Value = "Row Index"
ActiveSheet.Range("D2").Font.Bold = True
ActiveSheet.Range("D2").HorizontalAlignment = xlCenter
ActiveSheet.Range("E2").Value = "Row Iterator"
ActiveSheet.Range("E2").Font.Bold = True
ActiveSheet.Range("E2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("D" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("E" & N + 2).Value = M.Row
N = N + 1
Next M
Set my_range = Union(ActiveSheet.Range("A10:A2"), ActiveSheet.Range("A1:A2"))
ActiveSheet.Range("F1").Value = "UNION(A10:A2,A1:A2)"
ActiveSheet.Range("F1").Font.Bold = True
ActiveSheet.Range("F1").HorizontalAlignment = xlCenter
ActiveSheet.Range("F1:G1").Merge
ActiveSheet.Range("F2").Value = "Row Index"
ActiveSheet.Range("F2").Font.Bold = True
ActiveSheet.Range("F2").HorizontalAlignment = xlCenter
ActiveSheet.Range("G2").Value = "Row Iterator"
ActiveSheet.Range("G2").Font.Bold = True
ActiveSheet.Range("G2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("F" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("G" & N + 2).Value = M.Row
N = N + 1
Next M
Set my_range = Union(ActiveSheet.Range("A10:A2"), ActiveSheet.Range("A1:A2"), ActiveSheet.Range("A11:A12"))
ActiveSheet.Range("H1").Value = "UNION(A10:A2,A13:A15,A11:A12)"
ActiveSheet.Range("H1").Font.Bold = True
ActiveSheet.Range("H1").HorizontalAlignment = xlCenter
ActiveSheet.Range("H1:I1").Merge
ActiveSheet.Range("H2").Value = "Row Index"
ActiveSheet.Range("H2").Font.Bold = True
ActiveSheet.Range("H2").HorizontalAlignment = xlCenter
ActiveSheet.Range("I2").Value = "Row Iterator"
ActiveSheet.Range("I2").Font.Bold = True
ActiveSheet.Range("I2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("H" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("I" & N + 2).Value = M.Row
N = N + 1
Next M
The results are something that I cannot post because I cannot post images...sigh...they show that no matter how crazy the range is, when accessed via the Rows collection, they come in row order.
This seems to show that the rows are consistently returned in order no matter what crazy thing I do with the range if I access it via the Rows collection. I'm thinking that this means the approach of just stepping backwards through the range (as suggested in the comments) will work.
This code should do the trick.
With one clarification: From a VBA perspective Range("A2:A10") and Range("A10:A2") are exactly the same (i.e. they return the same address: $A$2:$A$10). In order to loop one way or another, you'll need to pass another argument.
EDIT
It takes the Overall_Range that you provide, then the direction of Up or Down then assigns values to variables to use in the For statement.
No selections used.
Option Explicit
Sub LoopOrderTest()
Dim Overall_Range As Range
Dim sLoopDir As String
Dim iTtlRows As Integer
Dim iLoopStep As Integer
Dim iLoopFrom As Integer
Dim iLoopTo As Integer
Dim n As Integer
Set Overall_Range = Range("A2:A10")
sLoopDir = "Up" 'or "Down"
iTtlRows = Overall_Range.Rows.Count 'Get total rows
'Assign for loop control items based on sLoopDir value
If sLoopDir = "Up" Then
iLoopFrom = 1
iLoopTo = iTtlRows
iLoopStep = 1
ElseIf sLoopDir = "Down" Then
iLoopFrom = iTtlRows
iLoopTo = 1
iLoopStep = -1
End If
Dim i As Integer 'used only to put items in cells for testing
i = 1
For n = iLoopFrom To iLoopTo Step iLoopStep
'do stuff.
'for now just print a number showing the order that the loop works through
Overall_Range.Cells(n, 1).Value = i
i = i + 1
Next n
End Sub
This shows what happens when I set sLoopDir = "Up" and run the code. Numbers ascending indicate it loops from top to bottom.
This shows what happens when I set sLoopDir = "Down" and run the code. Numbers descending indicate it loops from bottom to top.
Related
I have a nested for loop that first runs through 10-15k rows, compares a cell in that row to another table that is 40k+ rows, if it finds a match, it returns that match, otherwise "no record" is written in a cell. the code works fine, just investigating an alternative approach to make it run faster. currently, 13000 lines takes about 50 min to an hour to run. I've looked into arrays, but loading an array with 40k+ items seems like the wrong route to take. the report is often run bits at a time, so when it is first created it may have 2k rows, then 3k rows may be added to it later, the code below will skip over rows it has already checked and pick up where it left off. any help is appreciated
For i = 2 To lastRow
If Cells(i, 83).Value <> "" Then GoTo NextIteration:
Sheets("mft Rpt").Cells(i, 83) = "No Record"
model = Sheets("MFT RPT").Cells(i, 11).Value
trimModel = Replace(Replace(model, " ", ""), "-", "")
For j = 1 To lastCollateralRow
If trimModel = Sheets("Promosheet Table").Cells(j, 1).Value Then
Sheets("MFT RPT").Cells(i, 83) = Sheets("promosheet Table").Cells(j, 3).Value
End If
Next j
NextIteration:
Next i
This ia just a proof of concept, you will need to adjust variables and ranges to suit your needs.
Sub ProofOfConcept()
Dim rngList As Range
Dim rngMatch As Range
Dim arrList As Variant
Dim arrMatch As Variant
Set rngList = Range("A1:A50000")
arrList = Application.Transpose(rngList.Value)
Set rngMatch = Range("C1:D15000")
arrMatch = Application.Transpose(rngMatch.Value)
For a = 1 To 15000
For b = 1 To 50000
If arrMatch(1, a) = arrList(b) Then
arrMatch(2, a) = "Match found"
GoTo skip
End If
Next
skip:
Next
rngMatch = WorksheetFunction.Transpose(arrMatch)
End Sub
thanks #Michal
played with it a bit. I trimmed down the run time from almost an hour to about 7 or 8 min using this code. works beautifully!!
Dim promoList As Range
Dim rngMatch As Range
Dim arrList As Variant
Dim arrMatch As Variant
Dim z
Set promoList = Sheets("promosheet table").Range("A1:A" & lastcollateralRow)
arrList = Application.Transpose(promoList.Value)
Set rngMatch = Sheets("Mft rpt").Range("K2:K" & lastRow)
arrMatch = Application.Transpose(rngMatch.Value)
For z = LBound(arrMatch) To UBound(arrMatch)
arrMatch(z) = Replace(Replace(arrMatch(z), " ", ""), "-", "")
Next
For A = 1 To lastRow
If Cells(A + 1, 83).Value <> "" Then GoTo skip:
Sheets("mft rpt").Cells(A + 1, 83) = "No Record"
For b = 1 To lastcollateralRow + 1
If arrMatch(A) = promoList(b) Then
Sheets("mft rpt").Cells(A + 1, 83) = promoList(b, 3)
GoTo skip
End If
Next
skip:
Next
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
Objective:
Dynamically generating a (100% Stacked) graph based on data in a spreadsheet.
Conditions:
I have a list sites with repetitive milestones (each site uses the same 4 milestones, but the milestones differ between projects. This functionality will be used in the trackers for several projects).
Current State:
It's drawing the stacked barchart as desired, but I cant seem to get the legend (series) to be renamed to the unique keys in the dictionary that is being built from the identified milestones.
Data Setup:
Columns X3 and beyond has the list of milestones. there are 40 records (2 blank lines) with 4 unique values. The d1 dictionary contains the unique 4 values as displayed by the output into column R (for testing only).
Image: List of data and location/milestones
All code pertaining to drawing the graph:
With Worksheets("Sheet1")
.Columns.EntireColumn.Hidden = False 'Unhide all columns.
.Rows.EntireRow.Hidden = False 'Unhide all rows.
.AutoFilterMode = False
lastrow = Range("W" & Rows.Count).End(xlUp).Row
'If MsgBox("Lastrow is: " & lastrow, vbYesNo) = vbNo Then Exit Sub
End With
Dim MyLocationCount As Integer
Dim MyMilestoneCount As Integer
'Use VbA code to find the unique values in the array with locations.
'GET ARRAY OF UNIQUE LOCATIONS
Worksheets("Sheet1").Range("W3:W" & lastrow).Select
Dim d As Object, c As Range, k, tmp As String
Set d = CreateObject("scripting.dictionary")
For Each c In Selection
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.Keys
Debug.Print k, d(k)
MyLocationCount = MyLocationCount + 1
Next k
Range("U1:U" & d.Count) = Application.Transpose(d.Keys) '<-- For verification of the locations keys only.
'MsgBox (MyLocationCount)
'SET ARRAY CATEGORY VALUES
Dim d3 As Object
Set d3 = CreateObject("scripting.dictionary")
x = 0
Do
x = x + 1
d3.Add key:=x, Item:=1
'MsgBox "Key " & x & ": " & d3(x) & " Key Count: " & d3.Count
Loop Until x = MyLocationCount
Dim k3 As Variant
For Each k3 In d3.Keys
' Print key and value
Debug.Print k3, d3(k3)
Next
'------------
Range("T1:T" & d3.Count) = Application.Transpose(d3.Items)'<-- For verification of the locations items only.
'GET ARRAY OF UNIQUE MILESTONES
Worksheets("Sheet1").Range("X3:X" & lastrow).Select
Dim d1 As Object, c1 As Range, k1, tmp1 As String
Set d1 = CreateObject("scripting.dictionary")
For Each c1 In Selection
tmp1 = Trim(c1.Value)
If Len(tmp1) > 0 Then d1(tmp1) = d1(tmp1) + 1
Next c1
For Each k1 In d1.Keys
Debug.Print k1, d1(k1)
MyMilestoneCount = MyMilestoneCount + 1
Next k1
Range("R1:R" & d1.Count) = Application.Transpose(d1.Keys) '<-- For verification of the milestone keys only.
ActiveSheet.ChartObjects("Chart 2").Activate
'Delete all current series of data.
Dim n As Long
With ActiveChart
For n = .SeriesCollection.Count To 1 Step -1
.SeriesCollection(n).Delete
Next n
End With
'==== START PROBLEM AREA =====
'Loop the XValues and Values code as many times as you have series. make sure to increment the collection counter. Use array values to hardcode the categories.
x = 0
Do Until x = MyMilestoneCount
With ActiveChart.SeriesCollection.NewSeries
.XValues = Array(d.Keys)
.Values = Array(d3.Items)
x = x + 1
End With
'NAME MILESTONE
'MsgBox (d1.keys(x))
ActiveChart.FullSeriesCollection(x).Name = "=""Milestone " & x & """" '<==== THIS WORKS BUT IS NOT DESIRED.
'ActiveChart.FullSeriesCollection(x).Name = d1.Keys(x) '<==== THIS IS WHAT IM TRYING TO GET TO WORK.
Loop
'==== END PROBLEM AREA =====
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
'SET LEGEND SIZE
ActiveChart.Legend.Select
Selection.Left = 284.71
Selection.Width = 69.289
Selection.Height = 144.331
Selection.Top = 9.834
Selection.Height = 157.331
With ActiveSheet.ChartObjects("Chart 2").Chart.Axes(xlValue, xlPrimary)
'.Border.LineStyle = xlNone
.MajorTickMark = xlNone
.MinorTickMark = xlNone
.TickLabelPosition = xlNone
End With
End Sub
Anyone any idea on how to use the d1 keys instead of the manual naming? (See the <=== arrows).
I have code on how to color each section of the barchart based on the data that is determined in the spreadsheet (see image). right now my main challenge is getting the series properly named.
Thanks and have a great day!
Okki
I have been working on a macro that Archives: it selects rows with the right cell value and move them to another tab (while deleting the rows in the tab of origin).
My macro was working perfectly fine, but I decided to change my file and have different new tabs. When I computed my Macro in my new tabs, and it works on the right rows, and deletes them, but does not copy them in my "Archive tab" :
Sub Archive_Ongoing()
Test 2 : works for 2 arguments.
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("B90_Projects_OnGoing").UsedRange.Rows.Count
J = Worksheets("B90_Projects_Archived").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("B90_Projects_Archived").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("B90_Projects_OnGoing").Range("O1:O" & I)
Set yRg = Worksheets("B90_Projects_OnGoing").Range("T1:T" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Closed" And CStr(yRg(K).Value) <> "" Then
xRg(K).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Closed" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub'
Any one would be able to explain why?
Because you're decrementing your K variable within the FOR loop, which is also incrementing it. Your K variable never changes. Comment out K = K - 1 and report back?
If you're doing that on purpose to evaluate / delete a single line and shift the next values up then you might want to have a K2 variable that you increment like this:
For K = 1 To xRg.Count
If CStr(xRg(K - K2).Value) = "Closed" And CStr(yRg(K - K2).Value) <> "" Then
xRg(K - K2).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K - K2).EntireRow.Delete
If CStr(xRg(K - K2).Value) = "Closed" Then
K2 = K2 + 1
End If
J = J + 1
End If
Next
Hey guys I am new to VBA for excel and I am stuck with a problem.
I am trying to do some calculations for data input and I have to make my program stop displaying values on the worksheet before "Discrepancy" reaches any less than 5. This then should make both columns "Money" and "Discrepancy" stop together. After, the program will then start in another column (column "I1" for "Money2" and J1" for "Discrepancy2") when t=10 is inputted into the formula and the values are displayed in Columns I2 and J2 until till the end.
I'm not sure how to stop it before it reaches and also how to stop the other column simultaneously. I'm also not sure if it will continue for another t=10.
Any advice
Sub solver2()
Dim t As Double, v As Double, i As Integer
Dim rowG As Integer, rowH As Integer
i = 0: v = 0 'related to formuala
'Range("A3").Select
'Range("D3").Select
Range("G1").Value = "Money"
Range("H1").Value = "Discrepancy"
Range("G2").Select
For t = 0 To tf Step delta
ActiveCell.Offset(i, 0) = t
ActiveCell.Offset(i, 1) = v
v = v + delta * accel(t, v)
i = i + 1
Next t
rowG = ActiveSheet.Range("G2").End(xlDown).row
rowH = ActiveSheet.Range("H2").End(xlDown).row
For i = rowG To 1 Step -1
Dim val1 As Long
val1 = ActiveSheet.Range("G" & i).Value
If (val1 > 5) Then
ActiveSheet.Range("G" & i).EntireRow.Delete
End If
Next i
For i = rowH To 1 Step -1
Dim val2 As Long
val2 = ActiveSheet.Range("G" & i).Value
If (val2 > 5) Then
ActiveSheet.Range("G" & i).EntireRow.Delete
End If
Next i
For t = 0 To 10 Step delta 'This steps it per delta input
Range("I1").Value = "Money2"
Range("J1").Value = "Discrepancy2"
Range("I2").Select
ActiveCell.Offset(i, 0) = t
ActiveCell.Offset(i, 1) = v
v = v + delta * accel(t, v)
i = i + 1
Next t
End Sub
If you just need the cells to appear empty, you could use conditional formatting to set the text and background colors the same.
You might try a do while loop instead of a for loop to set the values in the first set:
Do While t <= tf And v < 5
ActiveCell.Offset(i, 0) = t
ActiveCell.Offset(i, 1) = v
v = v + Delta * accel(t, v)
i = i + 1
t = t + Delta
Loop
I'm not sure what you intended for the other columns, but this loop would leave t at the value you would use if you mean to continue where the first column left off