I have the following problem to solve to increase the speed at which the code performs the task.
I have a table with names of Hire Cars and two dates - From and To. I need to go through the range (say 10k rows) check and highlight all overlapping dates.
No Hire Car From To
1 ABC 01 Jan 12 12 Jan 12
2 ABC 14 Jan 12 15 Jan 12
3 ABC 25 Jan 12 02 Feb 12
4 DEF 01 Jan 12 12 Jan 12
5 DEF 12 Jan 12 02 Feb 12
6 DEF 14 Jan 12 15 Jan 12
For hire car DEF there are overlapping days, double counting in fact which i need to be able to highlight so that the user can quickly identify and correct.
This is the code that I have developed. The problem is that if you have a Range of 10k Rows it is extremely slow.
I am using Windows 7 Ultimate with Office/Excel 2010
Function CheckOverlap(StartLine, EndLine, StartColumn)
Dim i As Integer, y As Integer
Dim DateToCompare
Dim HireCar
Dim Count As Integer
Dim Msg, Style, Title, Response
'Check StartDate Column
For i = StartLine To EndLine
DateToCompare = Cells(i, StartColumn)
HireCar = Cells(i, 2)
For y = StartLine To EndLine
'If we are at the same line with DateToCompare cell then we should not perform any check
If i <> y Then
If DateToCompare >= Cells(y, StartColumn) And DateToCompare <= Cells(y, StartColumn + 1) And HireCar = Cells(y, 2) Then
'We should highlight both cells that contain overlapping dates
ActiveSheet.Cells(i, StartColumn).Interior.Color = 5296274
ActiveSheet.Cells(y, StartColumn).Interior.Color = 5296274
End If
End If
Next y
Next i
HireCar = 0
'Check EndDate Column
For i = StartLine To EndLine
DateToCompare = Cells(i, StartColumn + 1)
HireCar = Cells(i, StartColumn - 1)
For y = StartLine To EndLine
'If we are at the same line with DateToCompare cell then we should not perform any check
If i <> y Then
If DateToCompare >= Cells(y, StartColumn) And DateToCompare <= Cells(y, StartColumn + 1) And HireCar = Cells(y, StartColumn - 1) Then
'We should highlight both cells that contain overlapping dates
ActiveSheet.Cells(i, StartColumn + 1).Interior.Color = 5296274
ActiveSheet.Cells(y, StartColumn + 1).Interior.Color = 5296274
End If
End If
Next y
Next i
'Last check: If the starting and ending date are the same
For i = StartLine To EndLine
If Cells(i, StartColumn) - Cells(i, StartColumn + 1) = 0 Then
ActiveSheet.Cells(i, StartColumn).Interior.Color = 5296274
ActiveSheet.Cells(i, StartColumn + 1).Interior.Color = 5296274
End If
Next i
' If there are no Overlap Days in Database skip filtering
' StartDate and EndDate Column
' Count Cells with Interior.Color = 5296274 (Green Colour)
Count = 0
For i = StartLine To EndLine
If Cells(i, StartColumn).Interior.Color = 5296274 Then
Count = Count + 1
End If
Next i
' Msg if Database has no Overlap Days
Msg = "Validation check completed. There are 'NO' Overlap Days"
Style = vbOKOnly
Title = "Cash Flow"
' Require on Error Resume Next in case Database is NOT filtered
On Error Resume Next
If Count = 0 Then
ActiveSheet.ShowAllData
Response = MsgBox(Msg, Style, Title)
Exit Function
Else
Call Filter_Colour
End If
MsgBox "Any Green highlights indicate Overlap Days"
End Function
The fastest approach would be to sort the table (first order: cars, second order: from-date)
Then for each line:
there is a collision iif the line above is the same car and the to-date from above is larger than the from-date of the current line.
You can do these steps either with VBA or Excel-Formulas.
Here is a simple algo to show you a blank when there's an overlap on the latter rows. To run this, it's strictly assumed that your CAR column is sorted as per sample shown in the question.
Option Explicit
'-- assuming the CAR names column is sorted
'-- so each car block in one place
'-- run on button click event
Sub FindOverlaps()
Dim i As Integer, j As Integer
Dim vInput As Variant
Dim rng As Range
Set rng = Sheets(2).Range("B2:E7")
vInput = WorksheetFunction.Transpose(WorksheetFunction.Transpose(rng))
For i = LBound(vInput) To UBound(vInput) - 1
For j = LBound(vInput) + 1 To UBound(vInput)
If vInput(i, 2) = vInput(j, 2) Then
If vInput(i, 4) = vInput(j, 3) Then
vInput(j, 3) = ""
vInput(j, 4) = ""
End If
End If
Next j
Next i
rng.Offset(0, 6).Resize(UBound(vInput), UBound(Application.Transpose(vInput))) = vInput
End Sub
Output:
EDIT AS PER OP'S COMMENT
Transpose the sorted data into the same range as per input data, so remove offset(0,4):
Add conditiona formatting to highlight anyrow that's null within the specified range. (otherwise entire sheet will be coloured where empty cells are)
Code changes:
rng.Offset(0, 6).FormatConditions.Delete
rng.Offset(0, 6).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="="""""
rng.Offset(0, 6).FormatConditions(1).Interior.ColorIndex = 20
Related
I have a question regarding finding and detecting gaps per row in VBA excel.
The dificult part is gaps that start on Friday and run until Thursday (FTGaps) need to be added up seperately and gaps starting on other days have to be counted seperately.
So for instance in the picture the result from the first row has to be: 1 FTGap and 1 Gap
And the second row has to be 1 FTGap.
But if there is a empty cell earlier in the row it has to be counted as a different gap.
So for instance the following rows output is 2 gaps and 1 FTGap.
I hope my question is clear.
Thanks in advance
What I tried
For Row = 3 To Worksheets("Kalender2").UsedRange.Rows.Count
GapDays = 0
FTGapDays = 0
For col = 2 To 55 'Worksheets("Kalender2").Cells(2,
Columns.Count).End(xlToLeft).Column
If Worksheets("Kalender2").Cells(Row, col) = "0" And
Worksheets("Kalender2").Cells(2, col).Value = "Friday" Then
FTGapDays = FTGapDays + 1
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays <> 0 Then
FTGapDays = FTGapDays + 1 'doortellen gap startend op
vrijdag
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays = 0 Then 'And Worksheets("Kalender2").Cells(2, Col).Value <>
"Friday" Then
GapDays = GapDays + 1 'eerste lege cel andere dag dan
vrijdag
End If
Next col
If col = 54 Then
Call EndGap
End If
Call EndGap
Next Row
'
And then the second Sub Endgap():
If FTGapDays <> 0 Then
If FTGapDays < 7 Then
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 7 And FTGapDays < 14 Then
FTGaps = FTGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 14 And FTGapDays < 21 Then
FTGaps = FTGaps + 2
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 21 And FTGapDays < 28 Then
FTGaps = FTGaps + 3
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 28 And FTGapDays < 35 Then
FTGaps = FTGaps + 4
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 35 And FTGapDay < 42 Then
FTGaps = FTGaps + 5
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays = 42 Then
FTGaps = FTGaps + 6
LegGaps = LegGaps + 2
End If
End If
End Sub
Please, test the next solution. It uses a kind of trick: Dividing a number to 0 in a formula will return an error. So, such a formula is placed two rows down after the last, then using SpecialCells(xlCellTypeFormulas, xlErrors) creates a discontinuous range of the gaps and process it. The processing result is returned two columns to the right of the last column. In the first such a column the 'Gaps' and in the second one 'FTGap'. The code assumes that the row keeping the days name is the second and the zero (0) seen in your pictures are values not string as you tried using in your code:
Sub extractGaps()
Dim sh As Worksheet, lastR As Long, lastCol As Long, rng As Range, arrCount, arrRows, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
If sh.Range("A" & lastR).HasFormula Then
If left(sh.Range("A" & lastR).Formula, 3) = "=1/" Then
sh.rows(lastR).EntireRow.ClearContents
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
End If
End If
lastCol = sh.cells(2, sh.Columns.count).End(xlToLeft).column
ReDim arrCount(1 To lastR - 2, 1 To lastCol)
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
For i = 3 To lastR
arrRows = countGaps(sh.Range("A" & i, sh.cells(i, lastCol)), lastR, lastCol)
arrCount(i - 2, 1) = arrRows(0): arrCount(i - 2, 2) = arrRows(1)
Next i
sh.Range("A" & lastR + 2).EntireRow.ClearContents
sh.cells(3, lastCol + 2).Resize(UBound(arrCount), 2).value = arrCount
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Function countGaps(rngR As Range, lastR As Long, lastCol As Long) As Variant
Dim sh As Worksheet: Set sh = rngR.Parent
Dim rngProc As Range, i As Long, A As Range, FTGap As Long, Gap As Long
Dim boolGap As Boolean, bigGaps As Double, mtchFr
Set rngProc = sh.Range(sh.cells(lastR + 2, 1), sh.cells(lastR + 2, lastCol)) 'a range where to place a formula returnig errors deviding by 0...
rngProc.Formula = "=1/" & rngR.Address
On Error Resume Next
Set rngProc = rngProc.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If rngProc.cells.count = rngR.cells.count Then
If IsNumeric(rngProc.cells(1)) Then countGaps = Array(0, 0): Exit Function
End If
If rngProc Is Nothing Then countGaps = Array(0, 0): Exit Function 'in case of no gaps...
Gap = 0: FTGap = 0: Debug.Print rngProc.Areas.count
For Each A In rngProc.Areas
Debug.Print sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)).Address: 'Stop
If A.cells.count < 7 Then
Gap = Gap + 1
ElseIf A.cells.count = 7 Then
If sh.cells(2, A.cells(1).column).value = "Friday" Then
FTGap = FTGap + 1
Else
Gap = Gap + 1
End If
Else 'for more than 7 empty cells:
'set the Friday day position in the empty cells range/area:
mtchFr = Application.match("Friday", sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)), 0)
If A.Columns.count - mtchFr < 6 Then 'no any FTGap existing:
Gap = Gap + 1
ElseIf A.cells.count - mtchFr = 6 Then 'fix a FTGap
Gap = Gap + 1: FTGap = FTGap + 1
Else
bigGaps = ((A.cells.count - mtchFr) - i + 1) / 7
FTGap = FTGap + Int(bigGaps)
If mtchFr <> 1 Then Gap = Gap + 1 'the gap before Friday
If A.cells.count - i + 1 - Int(bigGaps) * 7 > 0 Then Gap = Gap + 1
End If
End If
Next A
countGaps = Array(Gap, FTGap)
End Function
Problem
We have a range (apparently "B3:BC" & UsedRange.Rows.count). The range is preceded by a row (B2:BC2) containing days of the week repeated in consecutively order: Monday, Tuesday, etc.
Cells for each row in the range contain either a 0 or some other value (integer? does not matter much). Consecutive 0's in a row (length > 0) are treated as a gap. We have two types of gaps:
a regular Gap: a range of consecutive 0's of any length > 0;
a Friday-through-to-Thursday-Gap (FtGap): a range of consecutive 0's, that starts on a Friday and ends on Thursday (length = 7).
For each row we want to count the number of Gaps and FtGaps, taking into account the following condition: a range of consecutive 0's that qualifies as a FtGap should not also be counted as a regular Gap.
Solution
To solve this problem, I've used range B3:BC20 for the data. Cells in this range have been populated randomly with either 0's or 1's (but this value could be anything) using =IF(RAND()>0.8,0,1). My row with "days of the week" starts with a "Monday", but this should make no difference.
I've used the following method:
Create two arrays for row days and the data.
Loop through each row array with nested loop through cols to access all cells per row.
On each new 0, increment the total Gap count (GapTrack) by 1. For each new 0, increment a variable (GapTemp) by 1 that tracks the length of the Gap. Reset GapTemp on the next non-0.
For each 0 on a "Friday", start incrementing a variable FtTemp. We keep checking if its value (length) has reached any multiple of 7. When it does, we increment the Ft count (FtTrack) by 1.
On each new non-0, check if FtTemp mod 7 = 0 and GapTemp Mod 7 = 0 and GapTemp > 0. If True, we will have added a regular Gap to our total count of the same length as one or more FtTemps. This violates the condition mentioned above. Remedy this by decrementing GapTrack by 1.
At the end of the row, we wrap GapTrack and FtTrack inside an array, assign it to a new key in a dictionary. At the start of the next row, we reset all our variables, and restart the count.
When the loop is finished, we end up with a dictionary that contains all our counts per row. We write this data away somewhere.
Code as follows with some further notes on what is happening. N.B. I've used "Option Explicit" to force proper declaration of all our variables.
Option Explicit
Sub CountGaps()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Kalender2")
Dim rngDays As Range, rngData As Range
Dim arrDays As Variant, arrData() As Variant
Set rngDays = ws.Range("Days") 'Named range referencing $B$2:$BC$2 in "Kalender2!"
Set rngData = ws.Range("Data") 'Named range referencing $B$3:$BC$20 in "Kalender2!"
'populate arrays with range values
arrDays = rngDays.Value 'dimensions: arrDays(1, 1) to arrDays(1, rngDays.Columns.Count)
arrData = rngData.Value 'dimensions: arrData(1, 1) to arrData(rngData.rows.Count, rngData.Columns.Count)
'declare ints for loop through rows (i) and cols (i) of arrData
Dim i As Integer, j As Integer
'declare booleans to track if we are inside a Gap / FtGap
Dim GapFlag As Boolean, FtFlag As Boolean
'declare ints to track current Gap count (GapTemp), sum Gap count (GapTrack), and same for Ft
Dim GapTemp As Integer, GapTrack As Integer, FtTemp As Integer, FtTrack As Integer
'declare dictionary to store GapTrack and FtTrack for each row
'N.B. in VBA editor (Alt + F11) go to Tools -> References, add "Microsoft Scripting Runtime" for this to work
Dim dict As New Scripting.Dictionary
'declare int (counter) for iteration over range to fill with results
Dim counter As Integer
'declare key for loop through dict
Dim key As Variant
'-----
'start procedure: looping through arrData rows: (arrData(i,1))
For i = LBound(arrData, 1) To UBound(arrData, 1)
'for each new row, reset variables to 0/False
GapTemp = 0
GapTrack = 0
GapFlag = False
FtTemp = 0
FtTrack = 0
FtFlag = False
'nested loop through arrData columns: (arrData(i,2))
For j = LBound(arrData, 2) To UBound(arrData, 2)
If arrData(i, j) = 0 Then
'cell contains 0: do stuff
If arrDays(1, j) = "Friday" Then
'Day = "Friday", start checking length Ft gap
FtFlag = True
End If
'increment Gap count
GapTemp = GapTemp + 1
If GapFlag = False Then
'False: Gap was not yet added to Total Gap count;
'do this now
GapTrack = GapTrack + 1
'toggle Flag to ensure continuance of 0 range will not be processed anew
GapFlag = True
End If
If FtFlag Then
'We are inside a 0 range that had a Friday in the preceding cells
'increment Ft count
FtTemp = FtTemp + 1
If FtTemp Mod 7 = 0 Then
'if True, we will have found a new Ft Gap, add to Total Ft count
FtTrack = FtTrack + 1
'toggle Flag to reset search for new Ft Gap
FtFlag = False
End If
End If
Else
'cell contains 1: evaluate variables
If (FtTemp Mod 7 = 0 And GapTemp Mod 7 = 0) And GapTemp > 0 Then
'if True, then it turns out that our last range STARTED with a "Friday" and continued through to a "Thursday"
'if so, we only want to add this gap to the Total Ft count, NOT to the Total Gap count
'N.B. since, in fact, we will already have added this range to the Total Gap count, we need to retract that step
'Hence: we decrement Total Gap count
GapTrack = GapTrack - 1
End If
'since cell contains 1, we need to reset our variables again (except of course the totals)
GapTemp = 0
GapFlag = False
FtTemp = 0
FtFlag = False
End If
Next j
'finally, at the end of each row, we assign the Total Gap / Ft counts as an array to a new key (i = row) in our dictionary
dict.Add i, Array(GapTrack, FtTrack)
Next i
'we have all our data now stored in the dictionary
'example of how we might write this data away in a range:
rngDays.Columns(rngData.Columns.Count).Offset(0, 1) = "Gaps" 'first col to the right of data
rngDays.Columns(rngData.Columns.Count).Offset(0, 2) = "FtGaps" 'second col to the right of data
'set counter for loop through keys
counter = 0
For Each key In dict.Keys
'resize each cell in first col to right of data to fit "Array(GapTrack, FtTrack)" and assign that array to its value ("dict(key)")
rngData.Columns(rngData.Columns.Count).Offset(counter, 1).Resize(1, 2).Value = dict(key)
'increment counter for next cell
counter = counter + 1
Next key
End Sub
Snippet of result:
Let me know if you experience any difficulties with implemention.
I am encountering a bug in VBA. As I am just a few weeks in, the code itself probably lacks a lot of best practices.
But besides that, in this specific case I get an Overflow error on the following line
dateDifference = DateDiff("d", currentDate, olderDate, vbMonday) in the section
'========================
'make cell BLUE
'========================
The full code is listed below. Does anybody have an idea, what is causing this issue? As a greenhorn my guess is, this has to do with constantly reassigning 3 variables in the loop?
Thanks a lot in advance.
Sub HrReporting_Step07_ApplyCellColouring()
ThisWorkbook.Activate
'========================
'Variables for looping
'========================
'declarations
Dim rowCount As Integer
Dim i As Integer
Dim srcColourColumnIntRed1 As Integer
Dim srcColourColumnIntRed2 As Integer
Dim srcColourColumnIntYellow As Integer
Dim srcColourColumnIntGreen As Integer
Dim srcColourColumnIntBlue1 As Integer
Dim srcColourColumnIntBlue2 As Integer
'variable declaration specifically for date calculations that are needed for colouring cells YELLOW or BLUE
Dim olderDate As Date
Dim currentDate As Date
Dim dateDifference As Integer
'assignments
srcColourColumnIntRed1 = Range("Table1[Availability Status]").Column
srcColourColumnIntRed2 = Range("Table1[Sum of Current Calendar % Allocated]").Column
srcColourColumnIntYellow = Range("Table1[Coming Available Category]").Column
srcColourColumnIntGreen = Range("Table1[CW-1]").Column
srcColourColumnIntBlue1 = Range("Table1[Current Calendar]").Column
srcColourColumnIntBlue2 = Range("Table1[Current Calendar End Date]").Column
rowCount = Range("Table1[Coming Available Category]").Count + 1
'========================
'make cell RED
'========================
For i = 2 To rowCount
'based on following conditions
' 1. Column "Sum of Current Calendar % Allocated" is lower or equal to 60 %
' 2. Column "Availability Status" = Now Available
If Cells(i, srcColourColumnIntRed1).Value = "Now Available" _
Or Cells(i, srcColourColumnIntRed2).Value <= 60 _
Then Cells(i, 1).Interior.Color = RGB(255, 0, 0)
Next i
'========================
'make cell YELLOW
'========================
For i = 2 To rowCount
'based on following condition
' 1. Column "Coming Available Category" = Available in the next 2 weeks
If Cells(i, srcColourColumnIntYellow).Value = "Resource First Available Day 1-7 Days" _
Or Cells(i, srcColourColumnIntYellow).Value = "Resource First Available Day 8-14 Days" _
Then Cells(i, 1).Interior.Color = RGB(255, 255, 0)
Next i
'========================
'make cell BLUE
'========================
For i = 2 To rowCount
'based on following conditions
' 1. Column "Current Calendar" unequal to "Booked To A Project"
' 2. Column "Current Calendar" unequal to empty
' 3. Column "Current Calendar End Date" < to 42 days AND > 12 days
olderDate = Cells(i, Range("Table1[Current Calendar End Date]").Column)
currentDate = Date
dateDifference = DateDiff("d", currentDate, olderDate, vbMonday)
If (Cells(i, srcColourColumnIntBlue1).Value <> "Booked To A Project" _
And Cells(i, srcColourColumnIntBlue1).Value <> "") _
Or (dateDifference <= 42 And dateDifference > 14) _
Then Cells(i, 1).Interior.Color = RGB(0, 0, 255)
Next i
'========================
'make cell GREEN
'========================
For i = 2 To rowCount
'based on following condition
' 1. Name does not exist in previous weeks' sheet, identified by VLOOKUP being #N/A
If WorksheetFunction.IsNA(Cells(i, srcColourColumnIntGreen)) _
Then Cells(i, 1).Interior.Color = RGB(0, 255, 0)
Next i
End Sub
It turned out that the comments from BigBen and Ron Rosenfeld solved my issue. I needed to simply declare dateDifference as Long, and the Overflow error was gone. Thank you.
I have the values on the range "A1:O1".
Each Column has a unique value in this range.
I need help to develop a loop that will fill down 04 times on each column the same Top Value (Column Value). Below a Pseudo Code
Sub FillDownRowsRandomly()
Dim i As Integer, j As Integer
'RamdomRow=Total of 04 unique ramdom numbers
'choosen from 01 to 06 {1,2,3,4,5,6}
'meaning that in a loop of 6 interations, when fill down
'2 will be Null or empty
'
For i = 1 To 15 'Columns "A" To "O"
For j = 2 To 7 '
'
Cells(RandomRow, i).Value = Cells(1, i).Value
Next j
Next i
End Sub
Below an Image where will be possible identify the result of the code.
Disregard the "Null" word written in the cells. I wrote that just to clarify that during the random loop, the code "ignored that cell".
Maybe something like:
Sub FillDownRowsRandomly()
Dim x As Long, y As Long, z As Long
With Sheet1 'Change accordingly
For y = 1 To 15
z = 0
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If .Cells(x, y) <> .Cells(1, y) Then
.Cells(x, y) = .Cells(1, y)
z = z + 1
End If
Loop
Next y
End With
End Sub
Loop the columns and randomly place the values till there are four in the six rows.
Sub FillDownRowsRandomly()
ActiveSheet.Range("A2:O7").ClearContents
Dim i As Long
For i = 1 To 15 'iterate the columns
Do Until Application.CountIf(ActiveSheet.Cells(2, i).Resize(6), ActiveSheet.Cells(1, i).Value) >= 4
Dim j As Long
j = Application.RandBetween(2, 7)
ActiveSheet.Cells(j, i).Value = ActiveSheet.Cells(1, i).Value
Loop
Next i
End Sub
I am using a macro from this thread to insert new rows
but the problem is when there is the same start date as end date I get the
Error 1004
can you help modify the VBA to skip those lines that produce the Error?
is there an easy way how to fill in the column B (marked red) the consequential dates to complete the table (one day per line)?
Start Date End Date Hours Type
02-01-18 02-01-18 8 one day
04-01-18 04-01-18 4 half day
05-01-18 06-01-18 16 multiple days
07-01-18 10-01-18 16 multiple days
11-01-18 11-01-18 8 one day
UPDATE:
you can use an if command to check to see if the dates match, then only run the check if they dont. the code will now add every subsequent date between the start and end date
Public Sub AAA_Format()
Dim i As Long
Dim d As Long
Dim LastRow As Long
Dim j As Long
Dim rng As Range, rng2 As Range
Dim startrow As Long, insertedrow As Long
Application.CutCopyMode = False
With Worksheets("Data")
LastRow = .UsedRange.Rows.Count
For i = LastRow To 2 Step -1 '' starts at bottom and goes up, that way inserting rows doesn impact it
'checks to see if 2 values are the same
If Not Cells(i, "B") = Cells(i, "C") Then
Debug.Print Cells(i, "B")
Debug.Print Cells(i, "C")
d = DateDiff("d", .Cells(i, "B"), .Cells(i, "C")) '' find differene
Debug.Print d
insertedrow = i + d
.Rows(i + 1 & ":" & insertedrow).Insert Shift:=xlDown
End If
For j = 1 To d
.Cells(i + j, 2) = .Cells((i + j) - 1, 2) + 1
.Cells(i + j, 3) = "what ever you want to calc end date as"
.Cells(i + j, 4) = "what ever you want to calc hours as"
.Cells(i + j, 5) = "what ever you want to calc day as"
Next j
Next i
End With
End Sub
To insert a column you can use
ActiveSheet.Range("D:D").EntireColumn.Insert
and to add formula to it you can use
LastRow = ActiveSheet.Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row '' this find bottom row by starting on very last row of sheet and moving up until it finds a cell with a value in it
Range("D2").Formula = "=IF(C2>0,C2,C1+1)"'' you might need to change , for ; depending on your language pack
Range("D2:D" & LastRow ).FillDown
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.