I have a large workbook with 9 sheets, each containing about 30-40 columns. I need to loop through each column individually and find values that are out of range or outliers and color them.
The only problem is that each column has unique values and I would need individual if statements for each. Is there a way to accomplish this without creating a bunch of individual for statements? I want to avoid having as many variables as possible and prevent it from taking an extremely long time to process. I have some example code of what I would need to do for each column. At the moment, all I would know how to do is repeat this code over and over for each column.
Dim rngData As Range, cellData As Range
Set rngData = Range("A2:A" & (numRows + 1))
For Each cellData In rngData
If cellData.Value < 0 Or cellData.Value > 200 Then
cellData.Interior.Color = RGB(126, 206, 124)
End If
Next cellData
You can use arrays to store outliners and column specification like this. It is not easy to fill in the arrays but one should do it :)
Dim oHI(100) As Long, oLOW(100) As Long, oCnt(100) As Long
Dim oCOL(100) As Long ' column numbers
Dim iColCnt As Long ' number of columns to process
oCOL(0) = 1 ' number of column #0
oHI(0) = 1000 : oLOW(0) = 200 ' high-low pairs for column #0
oCnt(0) = 44 ' count of valid elements in column #0
oCOL(1) = 5 ' number of column #1
oHI(1) = 100 : oLOW(1) = 0
oCnt(1) = 60
...
iColCnt = <count of columns to be processed, 0 relativ>
For i = 0 to iColCnt
Set rngData = Range(Cells(2, oCOL(i), Cells(oCnt(i) + 1, oCOL(i))
For Each cellData In rngData
If cellData.Value < oLOW(i) Or cellData.Value > oHI(i) Then
cellData.Interior.Color = RGB(126, 206, 124)
End If
Next cellData
Supposing all outliners are integers.
If the min and max changes by each column you'll have to identify them somewhere. I would put these in Excel somewhere to make it easy. However, you could also code it into VBA and have it dynamic using an array. In the below example I set up the limit for column 1. You'd have to include the min and max for all columns (which doesn't sound fun), but unless there's a dynamic method to the limits... this might be your best option.
Sub LoopCOLO()
Dim rngData As Range, cellData As Range, c As Long
Dim cMIN(1 To 40) As Double, cMAX(1 To 40) As Double
'Enter your min/maxex here based on column number)
cMIN(1) = 0
cMAX(1) = 200
cMIN(2) = 100
cMAX(2) = 300
'if you get confused on column nubmers you could do
cMIN(Range("C1").Column) = 200
cMAX(Range("C11").Column) = 300
'Loop your columns
For c = 1 To UBound(cMAX) 'however many columns
Set rngData = Range(Cells(1, c), Cells(numrows + 1, c))
'check values in each cell
For Each cellData In rngData.Cells
If cellData.Value < cMIN(c) Or cellData.Value > cMAX(c) Then
cellData.Interior.Color = RGB(126, 206, 124)
End If
Next cellData
Next c
End Sub
Related
want to split a time range into 1 hour intervals
split the given time range into 1 hour intervals from cell A2 and A3, the time range will be changed a serval time and on a (Macro) click it should split the given time range into 1 hour intervals.
Create an Hourly Sequence
Sub CreateHourlySequence()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim dt1: dt1 = ws.Range("A2").Value
Dim dt2: dt2 = ws.Range("A3").Value
Dim dfCell As Range: Set dfCell = ws.Range("C2")
dfCell.Resize(ws.Rows.Count - dfCell.Row + 1).ClearContents
Select Case False
Case IsDate(dt1), IsDate(dt2): Exit Sub
End Select
Dim dtDiff As Long: dtDiff = DateDiff("h", dt1, dt2)
Dim dtStart As Date, dStep As Long
Select Case dtDiff
Case Is > 0: dtStart = dt1: dStep = 1
Case Is < 0: dtStart = dt2: dStep = -1
End Select
Dim rCount As Long: rCount = Abs(dtDiff) + 1
Dim Data() As Date: ReDim Data(1 To rCount, 1 To 1)
Dim d As Long, r As Long
If dStep = 0 Then
Data(1, 1) = dtStart
Else
For d = 0 To dtDiff Step dStep
r = r + 1
Data(r, 1) = DateAdd("h", d, dtStart)
Next d
End If
dfCell.Resize(rCount).Value = Data
End Sub
If you are ok with a non-VBA solution, then you have some options.
Option 1: SEQUENCE
For the Excel version listed here, you could use the SEQUENCE function as suggested by chris neilsen.
Example:
Let's assume that your data starts at A1 like this:
Then, in C2, you could have :
=SEQUENCE((A3-A2)/VALUE("01:00:00")+1,1,A2,VALUE("01:00:00"))
Note that VALUE("01:00:00") represents 1 hour (but you could also use TIME(1,,) as suggested by Mayukh Bhattacharya).
Option 2: Dynamic Array Formula
You have an Excel version listed here, you can use a dynamic array formula .
Example:
Making the same assumptions as option 1, for where the data is, you could use a formula like this one:
=(ROW(INDIRECT("1:"&(A3-A2)/VALUE("01:00:00")+1))-1)*VALUE("01:00:00")+A2
Explanations:
Using the INDIRECT function inside the ROW function is a neat trick to get an array with consecutive values. For instance, INDIRECT("1:9") return the array containing rows 1 to 9 and passing it to ROW will return the array as a column like this {1;2;3;4;5;6;7;8;9} (we get only one element per row).
Since we don't know in advance how many steps we will take we calculate the number of elements using (A3-A2)/VALUE("01:00:00")+1 and concatenate it to "1:" to get the range of size that we need.
When we have the sequential array, we just need to make sure it starts by zero, which is why we remove 1 to all elements of the array like this:
ROW(INDIRECT("1:"&(A3-A2)/VALUE("01:00:00")+1))-1
Finally, we multiply each element of the array by the value corresponding to 1 hour and add the starting point in A2.
Option 3: Old array formula
Same idea as option 3 but using the old array formula explained here. Basically, you'll have to use Ctrl+Shift+Enter.
A Simple Solution given your example (to clear cells it is your job :-)
It would be better to write to an array but as example it should be ok.
Option Explicit
Sub TimeToHour()
Dim startTime As Double, endTime As Double, i As Double, z As Double
startTime = Range("a2")
endTime = Range("a3")
Columns(3).NumberFormat = Range("a2").NumberFormat ' Column C
z = 2
For i = startTime To endTime Step 1 / 24
Cells(z, 3) = i ' write to column c starting in row 2
z = z + 1
Next
End Sub
I have a data set where I need to compare the first number in each transect against each other.
For example, in the below data set I need to compare cells D2, D7, D12 and D17 and assign a value based on which one is the smallest number, the next smallest and so on. This will be used to assign the transect numbers in column A.
My issue is that the number of sections (in this example 4) and the number of transects (also 4 in this example) will vary. So the cells I need to compare will change.
I have written the code that calculates the number of transects, which is:
Dim tlength As Worksheet
Dim tb As Long *'tb=transect break*
Sub tlength_start_stop_coords()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("sheet1")
Set tlength = ThisWorkbook.Worksheets("transect lengths") *' assigns the sheet to a variable
for efficient coding*
tb = 0 *'counter to calculate the number of transects*
j = 2 *'counter for row*
Lastrow = Lastrow + 1 *'add a row to last row so that the last row includes a blank line.*
*'the following for loop is used to calculate the number of transects*
For i = 2 To Lastrow
If tlength.Range("D" & i) = vbNullString Then
If tlength.Range("D" & i - 1) <> vbNullString Then
tb = tb + 1 *'updates the counter*
End If
End If
Next i
tbtotal = tb *'stores the total counter in variable tbtotal for later use*
I think I may need to use a loop. But I am stuck trying to figure out how to manage the unknown number of comparisons in changing cell locations.
The desired result is in the below screenshot of the expected outcome, with results in column A. To begin with, I only need to get the number for the first row of each transect. Once I have that, I can copy using xldown.
Expected outcome:
Another possible data set and outcome expected might be:
enter image description here
with an expected outcome of:
enter image description here
Worked for me using your second set of sample data:
Sub Tester()
Dim tlength As Worksheet, i As Long, tNum As Long, v, vPrev, arr
Dim col As New Collection, e, c As Range, rng As Range
Set tlength = ThisWorkbook.Worksheets("transect lengths")
'collect all the Section 1 Latitudes and row numbers
For i = 2 To tlength.Cells(Rows.Count, "B").End(xlUp).Row
If tlength.Cells(i, "B") = 1 Then
col.Add Array(i, tlength.Cells(i, "D").Value) 'store start row and first Latitude
End If
Next i
SortCollection col, 2 'sort collection by second element in each array
tNum = 0
'loop over the sorted collection and assign the order of the transects
For Each e In col
tNum = tNum + 1
Set c = tlength.Cells(e(0), "B")
'following assumes all transects have at least 2 sections...
tlength.Range(c, c.End(xlDown)).Offset(0, -1).Value = tNum
Next e
End Sub
'Sort a collection of 0-based arrays in ascending order by the n'th element of each array
'Adapted from https://stackoverflow.com/a/3588073/478884
Sub SortCollection(col As Collection, n As Long)
Dim i As Long, j As Long, vTemp As Variant
For i = 1 To col.Count - 1 'Two loops to bubble sort
For j = i + 1 To col.Count
If col(i)(n - 1) < col(j)(n - 1) Then 'change to > for ascending sort
vTemp = col(j) 'store the lesser item
col.Remove j 'remove the lesser item
col.Add Item:=vTemp, before:=i 're-add the lesser item before the greater Item
End If
Next j
Next i
End Sub
I have written this code to add numbers in a column. It is not adding the last cell.
For example if there are three numbers 1, 2 and 3 it will sum up 1 and 2 and ignore value in third cell. When there is a fourth number 1, 2, 3 and 4 it adds 1, 2 and 3.
Sub add()
Dim Rng As Range, a As Integer
Set Rng = Range("b2", Range("b2").End(xlDown))
Counter = Rng.Count
a = 0
For i = 2 To Counter
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
Let's say the Counter = Rng.Count gives 4, and you start your i = 2 (possibly to keep title of your column). Your code will not print 4 digits, because you start loop from 2.
The counter should look like this:
Counter = Rng.Count + 1
and it will work
It is because .End(xlDown) - it works like CTRL + downarrow, and ends on the last not empty, or first not empty cell in the column. That's why when you delete value in specific row it will "break" the range. If you want to scan all rows, no matter if it's empty or not use the loop from the first row, and you will get the sum of the whole column range (starting from row 2 of course):
Sub SumWholeColumn()
'give the sum of all numbers in column B, starting from B2
Dim i, a As Long
Dim column, addr As String
a = 0
column = "b"
For i = 2 To Rows.Count
addr = column & i
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
If your range is fixed, you can speed up the calculation process by setting the range manually. Otherwise it will scan ALL rows. For example if you know, that your random numbers will not exceed row 1000, then you can use something like this:
Sub SumWholeColumn()
'give the sum of all numbers in column B, starting from B2
Dim i, a As Long
Dim maxRows As Integer
Dim column, addr As String
a = 0
column = "b"
maxRows = 1000
For i = 2 To maxRows
addr = column & i
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
Well I think that at the first time I did not understood your point then, I thought you would like to paste numbers in column B from 0 to the last row, starting from the B2 address. If so - this will work:
Sub add()
Dim i, a As Long
Dim column As String
Dim addr As String
a = 0
column = "b"
For i = 2 To Rows.Count
addr = column & i
ActiveSheet.Range(addr).Value = a
a = a + 1
Next i
End Sub
but today I realised that your title "Adding numbers in a column via Excel VBA
" is wrong and probably you are trying to achieve something else (because you are trying to give some value in ActiveCell?) and if so, please correct me:
you have actually some numbers in column B, and you would like to give in the ActiveCell the sum of all those numbers? The answer for this will be:
Sub SumAll()
'give the sum of all numbers in column B, starting from B2
Dim Rng As Range
Dim a, i As Long
Set Rng = Range("b2", Range("b2").End(xlDown))
Counter = Rng.Count + 1
a = 0
For i = 2 To Counter
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
You need to use "a" as Long, because Integer is up to 2147483647 and if you fill all rows in the column, starting from 0 and iterate the number by 1 to the last row, and sum the values it will give you 2147319811 - out of the Integer scope.
i value can be Integer (not Long as in my example), because "i" max value will not exceed the scope (Workbook rows are limited to 1048576). You can safely change i to Integer and save some KB's of memory :)
Is there a method to swap/switch data automatically in Excel?
For example:
I have an Excel sheet of almost 16.000 columns. Each column has 5 rows. The 5 rows contain information such as A,B,C,D,E but the data is not sorted, so I have the following: B,A,C,D,E or B,C,D,E.
I want to put all As first and the rows that do not contain an A so (B,C,D,E) to add a blank row before B.
I have only found how to do it manually and with less data and columns.
You can do this using a formula (fill down and then across):
Based on your comment, this below code should work for the 3 items you listed. If you have more options, just update the fields in the arrays
Sub CFixer()
Dim c As Long, WS As Worksheet, i As Integer, startRow As Integer, lastRow As Long, checkRNG As Range
Dim Check(2) As String 'must match below list
Check(0) = "BAC"
Check(1) = "GLO"
Check(2) = "HDP"
Dim T(2) As String ' must match list above
startRow = 1 'first row to evaluate
Set WS = ActiveSheet
lastRow = startRow + UBound(Check) 'last row to look to replace
For c = 1 To WS.UsedRange.Columns.Count
Set checkRNG = Range(WS.Cells(startRow, c), WS.Cells(lastRow, c))
For i = 0 To UBound(Check)
If Application.WorksheetFunction.CountIf(checkRNG, Check(i)) > 0 Then
T(i) = Check(i)
Else
T(i) = ""
End If
Next i
checkRNG.Value = Application.WorksheetFunction.Transpose(T)
Next c
End Sub
This will change rows as shown:
CORRECTED After Picture:
So i found this script on this site to color rows with the same cell-data and change the color when the celldata changes and it seems to work just fine, but i have two minor issues
It seems to only apply to the first 900 rows (I have an excel list with 8000+ rows)
It colors the entire row, is there a way to make it only color a certain part of the row?
Thanks in advance! here's the script:
Public Sub HighLightRows()
Dim i As Integer
i = 2 'start at 2, cause there's nothing to compare the first row with
Dim c As Integer
c = 2 'Color 1. Check http://dmcritchie.mvps.org/excel/colors.htm for color indexes
Do While (Cells(i, 1) <> "")
If (Cells(i, 1) <> Cells(i - 1, 1)) Then 'check for different value in cell A (index=1)
If c = 2 Then
c = 37 'color 2
Else
c = 2 'color 1
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.ColorIndex = c
i = i + 1
Loop
End Sub
Try this:
Public Sub HighLightRows()
Const START_ROW As Long = 2 '<< use a Constant for fixed values
Const VALUE_COL As Long = 1
Dim rw As Range, emptyCells As Long, i As Long, currentValue, tmp
Dim arrColors
arrColors = Array(37, 2)
Set rw = ActiveSheet.Rows(START_ROW)
currentValue = Chr(0) 'dummy "current value"
Do While emptyCells < 10 'quit after 10 consecutive empty cells
tmp = rw.Cells(VALUE_COL).Value
If Len(tmp) > 0 Then
If tmp <> currentValue Then
i = i + 1
currentValue = tmp 'save the new value
End If
'assign the color to a specific set of cells in the row
' starting at cell 1 and 5 columns wide
rw.Cells(1).Resize(1, 5).Interior.ColorIndex = arrColors(i Mod 2)
emptyCells = 0 'reset empty row counter
Else
emptyCells = emptyCells + 1 'increment empty row counter
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
End Sub
It looks like the code only evaluates if the cell is the same as the cell above it. Conditional formatting, as John Coleman said, would be more effective. With it values in the whole column can be evaluated instead of just adjacent ones. And, if I'm not mistaken, there's a setting to look for dup values since Excel 2007, so there doesn't have to be some kind of formula kung-fu to do it.
Unless I'm missing something, it's as simple as Conditional Formatting -> Highlight Cell Rules -> Duplicate Values.