This part of my macro is for coloring the cells in row B, depending on their value and the value of the corresponding cell in row Q. It works well, but when the file is large (sometimes over 500,000 rows), this step can really slow down the entire execution of the macro. There is also the likelyhood that I will need to add more colors down the road, which will mean more IF statement lines which will slow it down even more.
Dim LastRow As Long
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long, r1 As Range, r2 As Range
For i = 11 To LastRow
Set r1 = Range("B" & i)
Set r2 = Range("Q" & i)
If r2 = "001111" Then r1.Interior.Color = vbGreen
If (r1 < 4 Or r1 > 0) And (r2 <> "001111") Then r1.Interior.Color = vbYellow
If (r1 > 3 Or r1 < 1) And (r2 <> "001111") Then r1.Interior.Color = vbRed
Next i
I tried using some code for conditional formatting on the entire row. This is much faster, but I wasn't able to figure out how to include the value of the cell in column Q as a condition. I was also limited to no more conditions than three.
Is there a way to accomplish this task in a way that is faster than my current code that will also allow for more conditions/colors in the future?
Scratch my previous attempt. I do agree that Range.AutoFilter might even be better:
Sub Test()
Dim lr As Long, rng As Range
With Sheet1
'Get last used row of data and set range
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rng = .Range("B10:Q" & lr)
'Apply first filter and color Green
rng.AutoFilter 16, "001111"
If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbGreen
'Apply second filter and color Yellow
rng.AutoFilter 16, "<>*001111*"
rng.AutoFilter 1, "<4", xlAnd, ">0"
If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbYellow
'Apply third filter and color Red
rng.AutoFilter 1, ">3", xlOr, "<1"
If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbRed
'Remove AutoFilter
rng.AutoFilter
End With
End Sub
I guess the fastest would be to use an array? Maaaaybe some filter but I'm just gonna do the array for now:
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Tabelle1").Range("B11:B500000") = 1
ThisWorkbook.Sheets("Tabelle1").Range("Q11:Q500000") = 2
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim r1
Dim r2
r1 = ThisWorkbook.Sheets("Tabelle1").Range("B11:B" & LastRow)
r2 = ThisWorkbook.Sheets("Tabelle1").Range("Q11:Q" & LastRow)
For i = LBound(r1) To UBound(r1)
If r2(i, 1) = "001111" Then r1(i, 1) = vbGreen
If (r1(i, 1) < 4 Or r1(i, 1) > 0) And (r2(i, 1) <> "001111") Then r1(i, 1) = vbYellow
If (r1(i, 1) > 3 Or r1(i, 1) < 1) And (r2(i, 1) <> "001111") Then r1(i, 1) = vbRed
Next i
With ThisWorkbook.Sheets("Tabelle1")
For i = LBound(r1) To UBound(r1)
.Range("B" & 10 + i).Interior.Color = r1(i, 1)
Next
End With
Application.ScreenUpdating = True
I wish we could apply the .Interior.Color all in one go but I can't get that to work. If someone else does, I'd really like to know too! This executes in 24.75s on my machine. Oh and I didn't check your logic for the <, > things, I just added an array. It will likely break if something unexpected is written in one of the cells, like a string or something.
Also I assume you use IFs instead of elseif for a reason? Not like it really matters if done in an array, just curious.
Related
I am looking for a VBA solution to be able to:
Look for duplicated values in column "A" and format. (Possible with the code below)
With each subsequent duplicate found, the code should sum all the values from Columns "J" through "N" on the first value and fill the duplicated cell black (help)
Sub CombineDuplicates()
Dim Cell As Variant
Dim PList As Range
lRow = Worksheets("Material Planning").Cells(Rows.Count, 1).End(xlUp).Row
Set PList = Worksheets("Material Planning").Range("A4:A" & lRow)
For Each Cell In PList
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(PList, Cell) > 1 Then
'Highlight duplicate values in red color
cRow = Cell.Row
Range("A" & cRow & ":R" & cRow).Interior.Color = RGB(0, 0, 0)
Else
Cell.Interior.Pattern = xlNone
End If
Next
End Sub
Please see the picture for reference. Top is unfiltered data and the bottom is how it should look after the macro runs. Please let me know if you need any more information. Thanks in advance!
This uses a dictionary to detect duplicates and a class to keep your data organized
Place this piece inside of a class module:
Option Explicit
Private data As datasum
Private prow As Long
Private ptargetsheet As Worksheet
Private Type datasum
thirtyday As Long
threemonth As Long
expectedusage As Double
ordertarget As Double
stock As Long
avgdayleft As Long
dayleft As Long
pending As Long
End Type
Sub initialize(targetsheet As Worksheet, row As Long)
Set ptargetsheet = targetsheet
prow = row
End Sub
Sub addData(dataArray As Variant)
data.thirtyday = data.thirtyday + dataArray(1, 1)
data.threemonth = data.threemonth + dataArray(1, 2)
data.expectedusage = data.expectedusage + dataArray(1, 3)
data.ordertarget = data.ordertarget + dataArray(1, 4)
data.stock = data.stock + dataArray(1, 5)
data.avgdayleft = data.avgdayleft + dataArray(1, 6)
data.dayleft = data.dayleft + dataArray(1, 8)
data.pending = data.pending + dataArray(1, 9)
End Sub
Sub placeData()
With ptargetsheet
.Cells(prow, 6).Value = data.thirtyday
.Cells(prow, 7).Value = data.threemonth
.Cells(prow, 8).Value = data.expectedusage
.Cells(prow, 9).Value = data.ordertarget
.Cells(prow, 10).Value = data.stock
.Cells(prow, 11).Value = data.avgdayleft
.Cells(prow, 13).Value = data.dayleft
.Cells(prow, 14).Value = data.pending
End With
End Sub
And this piece in either your sheet module or a regular module:
Option Explicit
Sub CombineDuplicates()
Dim i As Long
Dim lRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim data As DataClass
With Sheets("Material Planning")
lRow = .Cells(.Rows.Count, 1).End(xlUp).row
For i = 4 To lRow
If Not dict.exists(.Cells(i, 1).Value) Then
Set data = New DataClass
data.initialize Sheets("Material Planning"), i
data.addData .Range(.Cells(i, 6), .Cells(i, 14)).Value
dict.Add .Cells(i, 1).Value, data
Else
dict(.Cells(i, 1).Value).addData .Range(.Cells(i, 6), .Cells(i, 14)).Value
dict(.Cells(i, 1).Value).placeData
.Range(.Cells(i, 1), .Cells(i, 14)).Interior.Color = RGB(0, 0, 0)
End If
Next i
End With
End Sub
This would be a simple, but probably not the fastest way of doing it:
Sub CombineDuplicates()
Dim Cell As Variant, PList As Range
Dim i As Long, j As Long, a As Long
Dim k(7) As Long
LRow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To LRow
Erase k
If Not Range("A" & i).Interior.Color = RGB(0, 0, 0) Then
For j = i + 1 To LRow
If Range("A" & i).Value = Range("A" & j).Value Then
For a = 0 To 7
k(a) = k(a) + Cells(j, a + 2)
Next a
Range("A" & j & ":N" & j).Interior.Color = RGB(0, 0, 0)
End If
Next j
For a = 0 To 7
Cells(i, a + 2) = Cells(i, a + 2) + k(a)
Next a
End If
Next i
End Sub
Essentially, for each row that isn't black (to avoid unnessecary calculaitons) we loop the rest of the range to look for duplicats. Add the values in the array k and keep looking.
Then we end the subloop by adding the number from the array to the current row, and keep going.
Should probably add something to clear the interior formatting first, for subsequent runs.
So after sitting and brainstorming for a while, I figured that I was trying to overcomplicate things. Thanks to your responses it helped me figure out the direction that I wanted to go. This is the current code that I have which is working flawlessly! It is a little slow, but since I am not going to be shifting through thousands of data points, its is manageable.
I tried to insert value added comments in the code to show the process:
Sub CombineDuplicates()
Dim Cell As Variant
Dim PList As Range
Worksheets("Material Planning").Unprotect
Set ws = Worksheets("Material Planning")
'set last row of working range
lRow = Worksheets("Material Planning").Cells(Rows.Count, 1).End(xlUp).Row
'Toggle parameter. If any cells in range are not colored then it will execute the macro to add common values
If Range("A4:A" & lRow).Interior.ColorIndex = xlColorIndexNone Then
For i = 1 To lRow
Application.ScreenUpdating = False
Application.EnableEvents = False
'since all of the "duplicate" values are listed near each oter, I just need to compare them one after another
Fst = ws.Range("A" & i)
Snd = ws.Range("A" & i + 1)
If Snd = Fst Then
'saves the Formula from the cell but just adds the value from the current cell to the next one
'this way even if there are more than 2 duplicates, the sum will continue on to the next cell
ws.Range("F" & i + 1).Formula = ws.Range("F" & i + 1).Formula & "+" & ws.Range("F" & i).Value
ws.Range("G" & i + 1).Formula = ws.Range("G" & i + 1).Formula & "+" & ws.Range("G" & i).Value
ws.Range("J" & i + 1).Formula = ws.Range("J" & i + 1).Formula & "+" & ws.Range("J" & i).Value
'The whole Row will be filled black so that it is not considered in the analysis
Range("A" & i & ":U" & i).Interior.Color = RGB(0, 0, 0)
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Else
'if there is already formatting on any cells in column A, this will remove the filled black formatting from all cells in the range
Range("A4:U" & lRow).Interior.Color = xlNone
ws.Range("F4:N" & ws.Cells(Rows.Count, 6).End(xlUp).Row).FillDown
ws.Range("P4:U" & ws.Cells(Rows.Count, 6).End(xlUp).Row).FillDown
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Worksheets("Material Planning").Protect
End Sub
Thank you all for your help and advice on this!
Excel has a built-in dedup function. Can you not programmatically copy the 'Simple Description' column at the top to the area underneath, run the dedup on the range containing the copy, then add sumifs to the remaining columns?
The code below creates the bottom table from the top table shown in the picture.
Sub Dedup()
Range("A1:A9").Copy
Range("A12").PasteSpecial
Range("B1:E1").Copy
Range("B12").PasteSpecial
Range("A13:A20").RemoveDuplicates Columns:=1
Range("B13").Formula = "=SUMIF($A$2:$A$9,$A13,B$2:B$9)"
Range("B13").Copy Destination:=Range("B13:E17")
End Sub
Of course, this doesn't maintain the structure with the black rows, but I haven't understood why you need that anyway, since you still have the original table.
And you'll want to do something a little more sophisticated about identifying the correct ranges, particularly for the copied table and when copying the sumif formula from the first cell to the last cell in the range that results from the deduplication. I've kept it simple here for expediency.
Edit: If you want the bottom table to reflect the structure of the original table, you could do a countif on each of the rows in the copy and insert the requisit number of rows that that gives you, and make the new rows black.
Paste Special xlPasteSpecialOperationAdd
This is a slow solution but may be easily understood.
It loops through the cells in column A and uses Application.Match to find the index (position) of the first occurrence. If it is not the same then it colors the row and uses PasteSpecial with xlPasteSpecialOperationAdd to add the found values to the values defined by the index.
Application.ScreenUpdating will speed up the code hiding the on-going 'worksheet dance'.
The Code
Option Explicit
Sub CombineDuplicates()
Dim ws As Worksheet
Dim PList As Range
Dim Cell As Range
Dim ColsAll As Range
Dim Cols1 As Range
Dim Cols2 As Range
Dim cIndex As Variant
Dim lRow As Long
Dim cRow As Long
Set ws = Worksheets("Material Planning")
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set PList = ws.Range("A4:A" & lRow)
Set ColsAll = ws.Columns("A:N")
Set Cols1 = ws.Columns("F:K")
Set Cols2 = ws.Columns("M:N")
Application.ScreenUpdating = False
For Each Cell In PList.Cells
cRow = Cell.Row
cIndex = Application.Match(Cell.Value, PList, 0) + 3
If cIndex < cRow Then
ColsAll.Rows(cRow).Interior.Color = RGB(0, 0, 0)
Cols1.Rows(cRow).Copy
Cols1.Rows(cIndex) _
.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
Cols2.Rows(cRow).Copy
Cols2.Rows(cIndex) _
.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
Else
ColsAll.Rows(cRow).Interior.Pattern = xlNone
End If
Next
Application.CutCopyMode = False
ws.Range("A3").Select
Application.ScreenUpdating = True
End Sub
Try this code, please. It should be very fast, using arrays and working only in memory and does not need to color anything. The processing result, meaning only the unique values with the necessary sum per each column will be dropped on a new sheet added after the processed one:
Sub CombineDuplicates()
`It needs a reference to 'Microsoft Scripting Runtime'
Dim LROW As Long, arrA, arr, arrR(4), arrF, dict As New Scripting.Dictionary
Dim sh As Worksheet, resSh As Worksheet, i As Long, j As Long, arrFin
Set sh = Worksheets("Material Planning")
LROW = sh.cells(rows.Count, 1).End(xlUp).row
arrA = sh.Range("A4:A" & LROW).value
arr = sh.Range("J4:N" & LROW).value
For i = 1 To UBound(arrA)
If Not dict.Exists(arrA(i, 1)) Then
For j = 0 To 4
arrR(j) = arr(i, j + 1)
Next j
dict.Add arrA(i, 1), arrR
Else
For j = 0 To 4
arrR(j) = dict(arrA(i, 1))(j) + arr(i, j + 1)
Next j
dict(arrA(i, 1)) = arrR
End If
Next i
ReDim arrFin(1 To dict.Count, 1 To 5)
ReDim arrF(1 To dict.Count, 1 To 1)
For i = 0 To dict.Count - 1
arrF(i + 1, 1) = dict.Keys(i)
For j = 0 To 4
arrFin(i + 1, j + 1) = dict.items(i)(j)
Next
Next i
Set resSh = Worksheets.Add(After:=sh) 'add a new sheet aftere the active one and drop the array at once
resSh.Range("A2").Resize(UBound(arrF), 1).value = arrF
resSh.Range("J2").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
This approach will allow running the code as many times you need, after eventual updates or just in case. Otherwise, it will return double dates each next time...
If you have a problem with adding the necessary reference, please run the next code before the one able to process your data:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub
Edited:
If you insist to keep all the range, and making black the interior of duplicates, you can try the next code, also very fast. It will also return in a newly created sheet, but only for testing reason. If it does what you want, the code can be easily adapted to overwrite the existing range of the active sheet:
Sub CombineDuplicatesKeepAll()
Dim LROW As Long, arrA, arrR(14), arrF, dict As New Scripting.Dictionary
Dim sh As Worksheet, resSh As Worksheet, i As Long, j As Long, arrFin, firstR As Long
Dim rngCol As Range, k As Long
Set sh = Worksheets("Material Planning")
LROW = sh.cells(rows.Count, 1).End(xlUp).row
firstR = 4 'first row of the range to be processed
arrA = sh.Range("A" & firstR & ":N" & LROW).value 'place the range to be processed in an array
ReDim arrFin(1 To UBound(arrA), 1 To UBound(arrA, 2)) 'set the final array at the same dimensions
For i = 1 To UBound(arrA) 'iterate between the array elements
If Not dict.Exists(arrA(i, 1)) Then 'if not a dictionary key as value in column A:A (array column 1):
arrR(0) = sh.Range("A" & i + firstR - 1).Address 'place the cell address like forst dictionary item array element
arrR(1) = i 'the array second element will be the array row (to update it later)
arrFin(i, 1) = arrA(i, 1) 'first element of the final array, on i row will be the first column value
For j = 2 To 14
arrR(j) = arrA(i, j) 'input the rest of the row values in the array to be the dictionary item
arrFin(i, j) = arrA(i, j) 'place the same values in the final array
Next j
dict.Add arrA(i, 1), arrR 'add the array built above like dictionary item
Else
arrR(0) = dict(arrA(i, 1))(0) 'keep the same call address like the first element of the array to be input as item
arrFin(i, 1) = arrA(i, 1) 'place the value in column A:A in the first column of the final array
arrR(1) = dict(arrA(i, 1))(1) 'keep the row of the first dictionary key occurrence
For j = 2 To 14 'fill the array with the values of all row columns
If j <= 9 Then 'for first 9 columns keep their value
arrR(j) = dict(arrA(i, 1))(j)
Else 'for the rest (J to N) add the existing value (in dictionary) to the cells value
arrR(j) = dict(arrA(i, 1))(j) + arrA(i, j)
End If
arrFin(i, j) = arrA(i, j) 'fill the final array with the row data
Next j
dict(arrA(i, 1)) = arrR 'place the array like dictionary item
If rngCol Is Nothing Then 'if range to be colored does not exist, create it:
Set rngCol = sh.Range("A" & i + firstR - 1 & ":N" & i + firstR - 1)
Else 'if it exists, make a Union between existing and the new one:
Set rngCol = Union(rngCol, sh.Range("A" & i + firstR - 1 & ":N" & i + firstR - 1))
End If
End If
Next i
'adapt te final array rows which used to be the first occurrence of the same dictionary key:
For i = 0 To dict.Count - 1
k = dict.items(i)(1) 'extract the previously memorized row to be updated
For j = 2 To 14 'adapt the row content, for the row range equivalent columns
arrFin(k, j) = dict.items(i)(j)
Next
Next i
'just for testing, paste the result in a new added sheet.
'If everything OK, the code can drop the value in the active sheet
Set resSh = Worksheets.Add(After:=sh)
'drop the array content at once:
resSh.Range("A4").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
If Not resSh Is Nothing Then _
resSh.Range(rngCol.Address).Interior.Color = vbBlack 'color the interior of the next occurrences
End Sub
I tried commenting the code lines, in a way to be easily understood. If something unclear, do not hesitate to ask for clarifications.
Please, send some feedback after testing it.
How can I implement if Sheet1 has row16 filled with anything it'll continue the function. If row16 is blank then skip function?
Initially I wanted row 2 to row15 from sheet1 to be copied into sheet2 and anything from row16 will be put on sheet3.
The code I have currently works fine with anything over 15 rows of data. But if it gets below 15 rows it gets buggy.
With Sheets("sheet1")
Set Rng = .Range("T2:T15")
End With
For i = 1 To Rng.Count * 2 Step 2
r = r + 1
Sheets("Sheet2").Range("C" & i + 13).Value = Rng(r).Value
Sheets("Sheet2").Range("D" & i + 14).Value = Rng(r).Value
Next i
With Sheets("sheet1")
Set Rng2 = .Range("T16", .Range("T" & Rows.Count).End(xlUp))
End With
For i2 = 1 To Rng2.Count * 2 Step 2
r2 = r2 + 1
Sheets("Sheet3").Range("C" & i2 + 7).Value = Rng2(r2).Value
Sheets("Sheet3").Range("D" & i2 + 8).Value = Rng2(r2).Value
Next i2
CountBlank vs CountA
Replace your second With block with the following one:
CountBlank
With Sheets("sheet1")
If Application.CountBlank(.Rows(16)) = .Columns.Count Then
Exit Sub
Else
Set Rng2 = .Range("T16", .Range("T" & Rows.Count).End(xlUp))
End If
End With
CountA
In this case, If Application.CountA(.Rows(16)) = 0 Then is unreliable because it will 'pick up' any cells containing formulas evaluating to "". Although sometimes you might need this behavior.
If you just want to check cell T16 do the following:
Len
With Sheets("sheet1")
If Len(.Range("T16").Value) = 0 Then
Exit Sub
Else
Set Rng2 = .Range("T16", .Range("T" & Rows.Count).End(xlUp))
End If
End With
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
I want to calculate mode for a range.
Range is a variable based on a condition.
Value 1 Value 2 Output
A 10 10
A 12 10
A 10 10
B 5 3
B 3 3
B 2 3
B 3 3
Like in the above case:
I need to calculate the mode(column C), with the range of value 2(column B), with a condition that Value 1(column A)is same in the range.
Sub mode()
Dim count
Dim rng As Range
x = 2
Do While Range("A" & x).Value = Range("A" & x + 1).Value
x = x + 1
Loop
Set rng = Range(Cells(x, 2), Cells(x + 1, 2))
md = WorksheetFunction.mode(rng)
Range("C" & x).Value = md
End Sub
Do You have any clue for that?
If your data are in A1:B7, then put this in C1 and copy down.
It's an array formula so needs to be confirmed with Ctrl, Shift and Enter, and curly brackets will appear round the formula.
=MODE(IF($A$1:$A$7=A1,$B$1:$B$7))
Of course, you could add the formula using VBA.
Enter the following formula as array formula (Ctrl+Shift+Enter) in cell C1 and pull it down
=MODE(IF(A:A=A1,B:B))
Note: In newer Excel versions you might need to use the MODE.SNGL function instead.
Image 1: Column C uses the array formula with an IF condition.
For further information see Conditional mode with criteria.
For reference rather than the best answer, below is the VBA I wrote which completes the same task as the array formula from the other answers:
Sub mode2()
Dim lastrow As Long, x As Long, b As Long
Dim cel As Range, cel2 As Range
Dim rng() As Variant
b = 2
lastrow = Range("A" & Rows.count).End(xlUp).Row
For Each cel In Range("A2:A" & lastrow)
If cel.Value = cel.Offset(1, 0).Value Then
If (Not Not rng) = 0 Then
ReDim rng(0 To 0)
rng(0) = cel.Offset(, 1).Value
Else
ReDim Preserve rng(0 To (cel.Row - b))
rng(cel.Row - b) = cel.Offset(, 1).Value
End If
Else
ReDim Preserve rng(0 To (cel.Row - b))
rng(cel.Row - b) = cel.Offset(, 1).Value
If (Not Not rng) <> 0 Then
Range("C" & cel.Row).Value = Application.WorksheetFunction.mode(rng)
b = cel.Row + 1
Erase rng()
End If
End If
Next cel
End Sub
This is probably not the cleanest or best macro, but it works and maybe it will help someone when a formula isn't an option. (at least it'll be useful for me if I ever go code bowling)
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.