Each of the cells in the “O2: O20” range is populated with numerical values. Next to each one of these cells there is a cell that is also populated with numerical values depending on the value that exists in "O2: 020". For example: If "O2" = 10.2 then the cell on its side "P2" = 1000 but then "P2" = 500, then "P2" = 600, then "P2" = 50; in short, "P2" can take any positive Natural value. I would like to calculate the difference between the previous value that "P2" takes and the current value that it can take as long as "O2" remains with the same value. If the value of "O2" changes, then the difference is not important to me: For example: if "O2" = 10.2 and "P2" = 50 and then "O2" = 10 and "P2" = 3000, in this case, no I want to know the difference, because "O2" is not the same for both cells.
I hope I could understand your problem. Please see this solution.
It is using Option Base 1.
Updated program for writing the difference into the Q column.
If the message is not needed please delete or Rem the line of the last MsgBox.
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
'Static declaration to safe the previous values and change status
Static vO As Variant
Static vP As Variant
Static bolOChanged() As Boolean
'Set up the ranges
Dim rngO As Range, rngP As Range, rngQ As Range
Set rngO = ThisWorkbook.ActiveSheet.Range("O2:O20")
Set rngP = ThisWorkbook.ActiveSheet.Range("P2:P20")
Set rngQ = ThisWorkbook.ActiveSheet.Range("Q2:Q20") 'Range for results
'If the change is not in the range then ignore
If Intersect(Union(rngO, rngP), Target) Is Nothing Then Exit Sub
'Prevent unhandelt multiply changes. If multiply changes required than the
'Target range shall be loop through
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
rngO.Value = vO
rngP.Value = vP
Application.EnableEvents = True
MsgBox "You cannot change more the one cell in the range of: " & Union(rngO, rngP).Address
Exit Sub
End If
'At the firs occasion the current status has to be saved
If VarType(vO) < vbArray Then
vO = rngO.Value
vP = rngP.Value
ReDim bolOChanged(1 To UBound(vO))
End If
Dim iIndex As Long 'Adjust the index of the array to the Row of Target cell
iIndex = Target.Row - rngO(1).Row + 1
If Not Intersect(rngO, Target) Is Nothing Then
'Change was in O range, so next P change shall be ignored
bolOChanged(iIndex) = True
Else
'rngP changed
If bolOChanged(iIndex) Then
'There was a previous O range change, ignore
bolOChanged(iIndex) = False 'Delete the recent change flag
vP(iIndex, 1) = Target.Value 'Store the value
Else
rngQ(iIndex).Value = Target.Value - vP(iIndex, 1)
MsgBox "Value change from: " & vP(iIndex, 1) & ", to: " & Target.Value & ". Difference is: " & Target.Value - vP(iIndex, 1)
vP(iIndex, 1) = Target.Value 'Store the value
End If
End If
End Sub
UPDATE: This version is working with multiply entries.
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
'Static declaration to safe the previous values and change status
Static vO As Variant
Static vP As Variant
Static bolOChanged() As Boolean
'Set up the ranges
Dim rngO As Range, rngP As Range, rngQ As Range
Set rngO = ThisWorkbook.ActiveSheet.Range("O2:O20")
Set rngP = ThisWorkbook.ActiveSheet.Range("P2:P20")
Set rngQ = ThisWorkbook.ActiveSheet.Range("Q2:Q20") 'Range for results
'If the change is not in the range then ignore
If Intersect(Union(rngO, rngP), Target) Is Nothing Then Exit Sub
'At the firs occasion the current status has to be saved
If VarType(vO) < vbArray Then
vO = rngO.Value
vP = rngP.Value
ReDim bolOChanged(1 To UBound(vO))
End If
Dim iIndex As Long 'Adjust the index of the array to the Row of Target cell
Dim item As Variant
For Each item In Target
iIndex = item.Row - rngO(1).Row + 1
If Not Intersect(rngO, item) Is Nothing Then
'Change was in O range, so next P change shall be ignored
bolOChanged(iIndex) = True
Else
'rngP changed
If bolOChanged(iIndex) Then
'There was a previous O range change, ignore
bolOChanged(iIndex) = False 'Delete the recent change flag
vP(iIndex, 1) = item.Value 'Store the value
Else
rngQ(iIndex).Value = item.Value - vP(iIndex, 1)
MsgBox "Value changed in cell " & item.Address & " from: " & vP(iIndex, 1) & ", to: " & item.Value & ". Difference is: " & item.Value - vP(iIndex, 1)
vP(iIndex, 1) = item.Value 'Store the value
End If
End If
Next item
End Sub
This solution uses more columns of your worksheet to store previous values to be compared to actual values. In my example, the values in cells O2 and O3 will always be the same.
Sub Populate_OandP()
'Store previous values
Call PreviousValues
'This code just simulates the data population in columns O and P
Dim intRndNumber As Integer
Range("O2").Value = 10.2
Range("O3").Value = 10
intRndNumber = Int((10 - 1 + 1) * Rnd + 1)
For i = 4 To 20
intRndNumber = Int((10 - 1 + 1) * Rnd + 1)
Cells(i, 15).Value = intRndNumber * 10
Next i
For i = 2 To 20
intRndNumber = Int((10 - 1 + 1) * Rnd + 1)
Cells(i, 16).Value = intRndNumber * 10
Next i
'Check differences
Call CheckDifferenceIfOChanges
End Sub
Sub PreviousValues()
For i = 2 To 20
Cells(i, 18).Value = Cells(i, 15).Value
Cells(i, 19).Value = Cells(i, 16).Value
Next i
End Sub
Sub CheckDifferenceIfOChanges()
For i = 2 To 20
If Cells(i, 18).Value = Cells(i, 15).Value Then
Cells(i, 20).Value = Cells(i, 19).Value - Cells(i, 16).Value
Else: Cells(i, 20).Value = "O columns value changed"
End If
Next i
End Sub
Related
I am trying to create a For and Do while loop in VBA. I want that when the value 'X' is entered in column A and if column W is equal to "T", all the rows below (column A) should be checked "X" until the next value "T" in column W.
My script does not work, only the row below is filled with "X" and the file closes (bug!)
Here is the complete code
Sub Chaine()
For Each Cell In Range("A2:A3558")
If UCase(Cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While Cell.Offset(0, 23) <> "T"
Cell.Offset(1, 0).Value = "X"
Loop
End If
Next Cell
End Sub
Try this:
Sub Chaine()
Dim c As Range, vW, flag As Boolean
For Each c In ActiveSheet.Range("A2:A3558").Cells
vW = UCase(c.EntireRow.Columns("W").value)
If UCase(c.value) = "X" And vW = "T" Then
flag = True 'insert "X" beginning on next row...
Else
If vW = "T" Then flag = False 'stop adding "X"
If flag Then c.value = "X"
End If
Next c
End Sub
Your Do While loop has to be problem as it doesn't change and will continue to check the same thing. It's unclear what you want to happen, but consider something like this as it moves to the right until you've exceeded the usedrange.
Sub Chaine()
Dim cell As Range
For Each cell In Range("A2:A3558").Cells
If UCase(cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While cell.Offset(0, 23) <> "T"
Set cell = cell.Offset(0, 1)
'not sure what this is supposed to do...?
'cell.Offset(1, 0).Value = "X"
If cell.Column > cell.Worksheet.UsedRange.Cells(1, cell.Worksheet.UsedRange.Columns.Count).Column Then
MsgBox "This has gone too far left..."
Stop
End If
Loop
End If
Next cell
End Sub
I just went off your description in the question. Your code is not doing what you want and it's not really how you would do this in my opinion. I figured I would put an answer that does what you ask but, keep it simple.
I'm guessing Target in the code refers to an event.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo SomethingBadHappened
'Checks if you are in the A column from the target cell that
'was changed and checks if only X was typed.
If (Target.Column = 1 And UCase(Target) = "X") Then
Dim colToCheck_Index As Integer
colToCheck_Index = 23 'W Column
Dim colToCheck_Value As String
Dim curRow_Index As Integer
curRow_Index = Target.Cells.Row
'Checks if the column we are checking has only a T as the value.
If (UCase(ActiveSheet.Cells(curRow_Index, colToCheck_Index).Value) = "T") Then
Application.EnableEvents = False
Do
'Set the proper cell to X
Range("A" & curRow_Index).Value = "X"
curRow_Index = curRow_Index + 1
'Set the checking value to the next row and check it in the
'while loop if it doesn't equal only T
colToCheck_Value = ActiveSheet.Cells(curRow_Index, colToCheck_Index)
'Set the last row to X on the A column.
Loop While UCase(colToCheck_Value) <> "T"
Range("A" & curRow_Index).Value = "X"
Application.EnableEvents = True
End If
Exit Sub
SomethingBadHappened:
Application.EnableEvents = True
End If
End Sub
I've written some code that deals with triggers. the main idea is to create dynamic triggers to cells of a sheet and based on the value of the cell the counter add or subtract from the total selected. Let me present it with an example and the code to make it clearer:
This is how my excel sheets appear.
A B C D E
1
2
3
to limit the scope, i have 4 columns and 3 rows, i want to assign triggers to A1, B1, C1 D1, E1 and more. therefore i wrote this that dynamically assign triggers to the cells.
For j = 1 To 3 ' row
For I = 1 To 4 ' columns
If Target.Column = I And Target.Row = j Then
If Target.Value = "Yes" Then
Yes_4 = Yes_4 + 1
ElseIf Target.Value = "No" Then
No_4 = No_4 + 1
ElseIf Target.Value = "Not applicable" Then
Not_Applicable_4 = Not_Applicable_4 + 1
End If
If Target.Value = "Green - Sufficient" Then
Green_4 = Green_4 + 1
ElseIf Target.Value = "Orange - Largely sufficient with points for follow-up" Then
Orange_4 = Orange_4 + 1
ElseIf Target.Value = "Red - Insufficient" Then
Red_4 = Red_4 + 1
End If
Range("O" & j).Value = "The ratings you selected are as follows:" + vbNewLine + "Yes: " & Str(Yes_4) + vbNewLine + "No: " & Str(No_4) + vbNewLine + "Green: " & Str(Green_4) _
+ vbNewLine + "Orange: " & Str(Orange_4) + vbNewLine + "Red: " & Str(Red_4) + vbNewLine + "No Applicable: " & Str(Not_Applicable_4)
End If
Next I
Next j
If the filled value of the cell is "Yes", the yes variable becomes yes + 1. not only for one cell, for every cell in the row, the summary is given in column O. for example: yes= 1, no =3, gree= 2 and so on. it functions well. The problem is that when a "Yes" is selected in a cell, the value in column O shows that yes = 1, but if you change your mind and change it from "Yes" to "No", the value in column O shows that yes = 1, no =1. Instead of "No" = 1 and "Yes" = 0.
Assign formulas to the result cells that reference the appropriate range, with the appropriate value, such as...
=countif(your range spec, "Yes")
=countif(your range spec, "Green")
If you need to adjust the range spec based on data conditions, you can update that formula in VBA reacting to the size of the range. Otherwise you don't need vba to compute the totals.
If you add a global variable to record the current value of the cell on SelectionChange, you can then check for changes and decrease the counter accordingly.
Dim sPrevious as string
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
sPrevious = Target.Value
End Sub
Then add into the existing Change event:
Private Sub Worksheet_Change(ByVal Target As Range)
For j = 1 To 3 ' row
For I = 1 To 4 ' columns
If Target.Column = I And Target.Row = j Then
If sPrevious <> Target.Value Then ''check if value has changed
If sPrevious = "Yes" Then
yes_4 = yes_4 - 1
ElseIf sPrevious = "No" Then
no_4 = no_4 - 1
ElseIf sPrevious = "Not applicable" Then
Not_Applicable_4 = Not_Applicable_4 - 1
End If
If sPrevious = "Green - Sufficient" Then
Green_4 = Green_4 - 1
ElseIf sPrevious = "Orange - Largely sufficient with points for follow-up" Then
Orange_4 = Orange_4 - 1
ElseIf sPrevious = "Red - Insufficient" Then
Red_4 = Red_4 - 1
End If
End If
Here's a different approach using a dictionary to track the counts, and also to store the display values for the message:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCheck As Range, rng As Range, rw As Range, c As Range, k, tmp
Dim dict As Object, msg As String, v
Set dict = GetTrackerDict()
Set rngCheck = Me.Range("A2:D10")
For Each rw In rngCheck.Rows
'change in this row?
If Not Application.Intersect(rw, Target) Is Nothing Then
For Each c In rw.Cells
v = c.Value
If dict.exists(v) Then 'counting this value?
tmp = dict(v) 'get array from dict
tmp(1) = tmp(1) + 1 'increment count
dict(v) = tmp 'return array
End If
Next c
'Build the message
msg = "The ratings you selected are as follows:"
For Each k In dict
tmp = dict(k)
msg = msg & vbNewLine & tmp(0) & ": " & tmp(1)
Next k
rw.EntireRow.Columns("O").Value = msg
Set dict = GetTrackerDict() 'reset tracking
End If
Next rw
End Sub
'Return a dictionary and with keys as the values to be counted
Function GetTrackerDict() As Object
Dim dict As Object
' (add in the order to be displayed)
Set dict = CreateObject("scripting.dictionary")
dict.Add "Yes", Array("Yes", 0) 'array = (displayName, count)
dict.Add "No", Array("No", 0)
dict.Add "Green - Sufficient", Array("Green", 0)
dict.Add "Orange - Largely sufficient with points for follow-up", Array("Orange", 0)
dict.Add "Red - Insufficient", Array("Red", 0)
dict.Add "Not applicable", Array("N/A", 0)
Set GetTrackerDict = dict
End Function
I have written a simple VBA script (code below) that should inspect every cell in a certain column. Here I want to do some string manipulation ( i wante to search for "." in the string and then take the right side, but because I could not get it to work I always take the 4 digit as a start). I then copy the manipulated string into another cell and later back. The code works, but for some reason, it takes ages to run on only 35 cells!
I´m still a kook on VBA and wanted to get input what could be the reason for it and what I could improve to get a faster runtime. Is it because I take all strings froms 4 up to 50 ?
Sub EditStatus()
Application.DisplayAlerts = False
ActiveSheet.Name = "Backend"
myNum = Application.InputBox("Please enter the row number until which you would like to update the status column (only for new entries)")
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
Range("T1:T200").Clear
Application.DisplayAlerts = True
End Sub
Thanks
No need for a loop. You can enter the formula in the entire range in 1 go and then convert them to values before putting the values back in Col J
Replace
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
With
With Range("T2:T" & myNum)
.Formula = "=MID(J2, 4, 50)"
.Value = .Value
Range("J2:J" & myNum).Value = .Value
End With
Alternatively, you can directly perform the same action in Col J without the helper column T. For example you can do all that in 1 line as explained HERE as well
Simply replace
For i = 2 To myNum
Cells(i, 20).Value = Mid(Cells(i, 10), 4, 50)
Cells(i, 10).Value = Cells(i, 20).Value
Next i
Range("T1:T200").Clear
with
Range("J2:J" & myNum).Value = Evaluate("Index(MID(" & "J2:J" & myNum & ", 4, 50),)")
Replace Values In-Place
Adjust the values in the constants section.
This solution overwrites the data and doesn't use a helper column, but you can test it with one indicated near the end of the code.
Solve the renaming (Backend) part as needed.
The Code
Option Explicit
Sub EditStatus()
' Define constants.
Const sPrompt As String = "Please enter the row number until which you " _
& "would like to update the status column (only for new entries)"
Const sTitle As String = "Enter Number"
Const wsName As String = "Backend"
Const First As Long = 2
Const cCol As Long = 10 ' J
Const Delim As String = "."
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Require input.
Dim Last As Variant
Last = Application.InputBox( _
Prompt:=sPrompt, Title:=sTitle, Default:=First, Type:=1)
' Validate input.
If VarType(Last) = vbBoolean Then
MsgBox "You cancelled."
Exit Sub
End If
If Last < First Then
MsgBox "Enter a number greater than " & First - 1 & "."
Exit Sub
End If
If Int(Last) <> Last Then
MsgBox "Enter a WHOLE number greater than " & First - 1 & "."
Exit Sub
End If
' Define column range.
Dim rg As Range
Set rg = wb.Worksheets(wsName).Cells(First, cCol).Resize(Last - First + 1)
' Write values from column range to array.
Dim Data As Variant
If rg.Rows.Count > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data = rg.Value
End If
' Declare additional variables
Dim cValue As Variant ' Current Value
Dim i As Long ' Current Row (Array Row Counter)
Dim fPos As Long ' Current Delimiter Position
' Replace strings containing the delimiter, with the sub string
' to the right of it.
For i = 1 To UBound(Data)
cValue = Data(i, 1)
If Not IsError(cValue) Then
fPos = InStr(1, cValue, Delim)
If fPos > 0 Then
Data(i, 1) = Right(cValue, Len(cValue) - fPos)
End If
End If
Next i
' Maybe rather test with the following (writes to column 20 ("T")).
'rg.Offset(, 10).Value = Data
' Write values from array to column range.
rg.Value = Data
End Sub
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.
I am fairly new to VBA but understand the basics. My question is as follows:
I need to divide the individual cells of an array with its corresponding offset cell (E3/E2, F3/F2, G3/G2, etc.) and store it in an array. Then, I need to find the 1st, 2nd, and 3rd smallest numbers of that array and highlight the cell in the first row of that column. Here is what I have:
Option Base 1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Private Sub test5()
Dim row As Integer
Dim column As Integer
Dim myArray(10) As Double
Dim myArray1(3) As String
Dim a As Long
Dim b As Long
Dim intQuizNumber As Integer
Dim intTestNumber As Integer
Dim intProjectNumber As Integer
intQuizNumber = 3
intTestNumber = 3
intProjectNumber = 3
On Error Resume Next
If Not Intersect(Target, Range(Range("D3"), Range("D3").End(xlDown))) Is Nothing Then
Range("1:1").Interior.Color = xlNone
row = ActiveCell.row
column = ActiveCell.column
For a = 1 To 10
myArray(a) = Cells(row, column + 1) / Cells(2, column + 1)
column = column + 1
Next a
row = ActiveCell.row
column = ActiveCell.column
'Evaluate("=RANK(E3,$E$3:$N$3,0)+COUNTIF($E$3:E3,E3)-1")
For b = 1 To 3
myArray1(b) = Evaluate("=CELL(""address"",OFFSET(" & Target.Offset(0, 1).Address & ",0,MATCH(SMALL(" & Target.Offset(0, 1).Address & ":" & Target.Offset(0, 3 + 3 + 3 + 1).Address & "," & b & ")," & Target.Offset(0, 1).Address & ":" & Target.Offset(0, 3 + 3 + 3 + 1).Address & ",0)-1))")
Next b
Union(Range(myArray1(1)).Offset(-row + 1, 0), Range(myArray1(2)).Offset(-row + 1, 0), Range(myArray1(3)).Offset(-row + 1, 0)).Interior.Color = 65535
Else
Range("1:1").Interior.Color = xlNone
End If
End Sub
I would like to replace the Evaluate statement in "b" loop with the one that I have commented out but can't seem to do it. I first need the value of the division and then I need to get the three lowest and highlight the cells. I've searched on Google thoroughly and can't figure this out. Any help would be greatly appreciated!!
Thank You
I'm not sure why you want to use RANK instead of what you have, but here's another way to get what you want.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
Dim vaNums As Variant, vaDenoms As Variant, aDivs() As Double
Dim wf As WorksheetFunction
Dim lSmall As Long
Dim rRow As Range
Dim rStart As Range
Const lCOLS As Long = 10
Const lMARKCNT As Long = 3
If Not Intersect(Target.Cells(1), Me.Range("D3", Me.Range("D3").End(xlDown))) Is Nothing Then
Set wf = Application.WorksheetFunction ' this just makes our code easier to read
'If these ever change, you only have to change them in one place
Set rRow = Target.Cells(1).Offset(0, 1).Resize(1, lCOLS)
Set rStart = Me.Cells(1, 5)
'Clear existing colors
rStart.Resize(1, lCOLS).Interior.ColorIndex = xlNone
'Read the current line and the 2nd line into arrays
'This shortcut creates two-dimensional arrays
vaNums = rRow.Value
vaDenoms = rStart.Offset(1, 0).Resize(1, lCOLS).Value
'Do the division and store it in aDivs()
ReDim aDivs(LBound(vaNums, 2) To UBound(vaNums, 2))
For i = LBound(vaNums, 2) To UBound(vaNums, 2)
aDivs(i) = vaNums(1, i) / vaDenoms(1, i) + (i / 10000)
Next i
'Find the nth smallest value and gets its position with MATCH
'Then use that position to color the cell
For i = 1 To 3
lSmall = wf.Match(wf.Small(aDivs, i), aDivs, False)
rStart.Offset(0, lSmall - 1).Interior.Color = vbYellow
Next i
End If
End Sub