I have a VBA Module that is trying to get all occurrences of a date in column G in one sheet. After finding the row of the occurrence, I'm saving other values from the sheet on the same row from different columns, i.e. bldg, and room, and numPerson.
What I'm trying to do after that is to get the call a function with the date, numPerson, bldg and room as arguments. The function FillDateCapacitiesInOccupancySheet should go to a different sheet and search column B for the bldg, get that row, then look for the room on the same row and place the numPpl on the row under the correct column for the date that was given. In the following code I get an Error 91 on the Loop While statement if I remove
If FoundCell Is Nothing Then
MsgBox "No Found Cell Address", vbInformation
Exit Sub
End If
The click function works fine if I remove the call to the function FillDateCapacitiesInOccupancySheet, but otherwise I get an error. Either the FoundCell or myRange is empty but I'm not sure why or how to fix it.
Sub ConflictButton_Click()
Dim sourceColumn As Range
Dim targetColumn As Range
Dim beginningDate As String, stringDate As String, month As String, day As String, year As String
Dim dates As Date
Dim occWS As Worksheet, excepWS As Worksheet
Dim beginningDateCell As Range, addDatesCells As Range, FindDateRow As Range
Dim datesArray(1 To 7) As Date, stringDatesArray(1 To 7) As String
Dim lLoop As Long, findRowNumber As Long
Dim tempMonth As String, tempDay As String
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
'Copy Building, Room, and Max Capacity Columns from sheet Table to sheet OccupancyByDate
Set sourceColumn = ThisWorkbook.Worksheets("Table").Columns("B:D").Rows("3:500")
Set targetColumn = ThisWorkbook.Worksheets("OccupancyByDate").Columns("B:D").Rows("3:500")
sourceColumn.Copy Destination:=targetColumn
'open FindConflictDates Form
FindConflictDatesForm.Show
'Set OccupancyByDate sheet Column E Row 2 (Column Header) to the Week Starting Date,
'get the week beginning string from what was saved from the FindConflictDatesForm
If WeekBeginningString <> "" Then
beginningDate = WeekBeginningString
WeekBeginningDate = CDate(beginningDate) ' convert String to Date
Set occWS = ThisWorkbook.Sheets("OccupancyByDate")
Set excepWS = ThisWorkbook.Sheets("Telework Exceptions")
' Fill the 7 dates into header in OccupanyByDate sheet Columns E - K row 2
Dim i As Integer
i = 1
For j = 5 To 11 ' From column E(5) to K (11)
dates = WeekBeginningDate - Weekday(WeekBeginningDate, vbUseSystemDayOfWeek) + i
occWS.Cells(2, j).Value = Format(dates, "dd-mmm-yyyy") ' write dates to OccByDate sheet
'Save dates to datesArray
datesArray(i) = dates
stringDate = CStr(dates) ' convert date to string
If Mid(stringDate, 2, 1) <> "/" Then ' 2 digit month
tempMonth = Left(stringDate, 2)
Else
tempMonth = Left(stringDate, 1) ' 1 digit month
month = GetMonthAbbreviation(tempMonth)
End If
If Left(Right(stringDate, 7), 1) <> "/" Then '2 digit day
day = Left(Right(stringDate, 7), 2)
Else
day = Left(Right(stringDate, 6), 1) ' 1 digit day
' day = Mid(stringDate, 4, 2)
End If
year = Right(stringDate, 4)
stringDatesArray(i) = day & "-" & month & "-" & year
i = i + 1 ' Add 1 to increment date of week
Next j
''''''''''''''''''''''''
' Search for dates on the TW Exception Sheet
Dim numPerson As Long, Bldg As String, Room As String, foundDate As String
numPerson = 0
For i = LBound(datesArray) To UBound(datesArray)
'Search for datesArray(i) on TW Exceptions sheet
Set myRange = excepWS.Range("G:G")
Set LastCell = myRange.Cells(myRange.Cells.count)
Set FoundCell = myRange.Find(what:=stringDatesArray(i), after:=LastCell, LookIn:=xlValues)
If Not FoundCell Is Nothing Then ' if value found in column
FirstFound = FoundCell.Address
findRowNumber = FoundCell.Row 'get row number of the found date in the column on TW Excep sheet
foundDate = FoundCell.Text 'get text value of first occurence of new date found in column
Do ' Find additional occurences of date in the sheet column
findRowNumber = FoundCell.Row
If FoundCell.Offset(0, -3).Value = 1 Then
numPerson = 1
End If
If FoundCell.Offset(0, -2).Value = 1 Then
numPerson = 1
End If
Bldg = FoundCell.Offset(0, 3).Text
Room = FoundCell.Offset(0, 4).Text
FillDateCapacitiesInOccupancySheet foundDate, numPerson, Bldg, Room 'if i remove this line I don't get an error
Set FoundCell = myRange.FindNext(FoundCell)
If FoundCell Is Nothing Then
MsgBox "No Found Cell Address", vbInformation
Exit Sub
End If
Loop While (FoundCell.Address <> FirstFound)
End If
Next i 'Get next dateArray value
End If 'End if WeekBeginningString <> ""
End Sub
Sub FillDateCapacitiesInOccupancySheet(fndDate As String, numPpl As Long, Buildg As String, Rm As String)
Dim occWS As Worksheet
Dim FndCell As Range, rng As Range
Dim myNewRange As Range, LastCell As Range
Dim foundBldg As String
Dim findRowNumber As Long, count As Long
Dim dateOffset As Integer
Dim FirstFound As String
count = 0
Set occWS = ThisWorkbook.Sheets("OccupancyByDate")
Set myNewRange = occWS.Range("B:B") ' search in building column
Set LastCell = myNewRange.Cells(myNewRange.Cells.count)
Set FndCell = myNewRange.Find(what:=Buildg, after:=LastCell, LookIn:=xlValues)
If Not FndCell Is Nothing Then ' if value found in column
FirstFound = FndCell.Address
findRowNumber = FndCell.Row 'get row number of the found building in the column on OccByDate sheet
foundBldg = FndCell.Text 'get text value of first occurence of new building found in column
Do ' Find additional occurences of date in the sheet column
findRowNumber = FndCell.Row
If FndCell.Offset(0, 1).Text = Rm Then ' if room passed into function equals room for the building
'Find the date column for the date passed into function
For j = 5 To 11 ' From column E(5) to K (11)
If occWS.Cells(2, j).Text = fndDate Then
dateOffset = j - 2
count = FndCell.Offset(0, dateOffset).Value + numPpl
' write count to cell
FndCell.Offset(0, dateOffset).Value = count
End If
Next j
End If
Set FndCell = myNewRange.FindNext(FndCell)
Loop While (FndCell.Address <> FirstFound)
End If
End Sub
Any help would be greatly appreciated.
I get an Error 91 on the Loop While statement
Here:
Set FndCell = myNewRange.FindNext(FndCell)
Loop While (FndCell.Address <> FirstFound)
If that Range.FindNext call doesn't find anything, FndCell is Nothing when the While condition gets evaluated, and that would be where error 91 is being raised; the If Not FndCell Is Nothing Then parent block means nothing as soon as FndCell is re-assigned.
You need to bail out when FndCell is Nothing. Consider using Exit Do for this:
If FndCell Is Nothing Then Exit Do
Loop While FndCell.Address <> FirstFound
Only exiting the smaller scope conveys intent better than exiting the entire procedure scope here, I find - even if all that's left to execute [for now] is an End Sub statement.
Consider declaring j and having Option Explicit at the top of the module, too!
Related
How can I place a formula in the first empty cell on Column F?
F3 is empty cell.
Need for that empty cell be =F2
Note: I'm looking for code to look for first empty cell F and I need to be able to insert in the first empty cell =F3.
Currently working with following code copied from here
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Select
Exit For 'This is missing...
End If
Next
Your existing code implies you want to consider truely Empty cells and cells that contain an empty string (or a formula that returns an empty string) Note 1. (Given you simply copied that code from elsewhere, that may not be the case)
You can use End(xlDown) to locate the first truely Empty cell, or Match to locate the first "Empty" cell in a range (either just empty string, or either empty strings or Empty cells, in different forms)
If you want to find the first truely Empty cell, or cell containing an empty string:
Function FindFirstEmptyOrBlankCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty or blank cell
Set FindFirstEmptyOrBlankCell = rng.Cells(StartingAt.Worksheet.Evaluate("Match(True, " & rng.Address & "=""""" & ", 0)"), 1)
End Function
If you want to find the first truely Empty cell, and ignore cells containing an empty string:
Function FindFirstEmptyCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty cell
If IsEmpty(StartingAt.Cells(1, 1)) Then
Set FindFirstEmptyCell = rng.Cells(1, 1)
ElseIf IsEmpty(StartingAt.Cells(2, 1)) Then
Set FindFirstEmptyCell = rng.Cells(2, 1)
Else
Set FindFirstEmptyCell = rng.End(xlDown).Cells(2, 1)
End If
End Function
And for completeness, if you want to find the fisrt cell containing an empty string, and ignore truely Empty cells:
Function FindFirstBlankCell(StartingAt As Range) As Range
Dim rng As Range
Dim idx As Variant
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first blank cell
idx = Application.Match(vbNullString, rng, 0)
If IsError(idx) Then
'There are no Blank cells in the range. Add to end instead
Set FindFirstBlankCell = rng.Cells(rng.Rows.Count, 1)
Else
Set FindFirstBlankCell = rng.Cells(idx, 1)
End If
End Function
In all cases, call like this
Sub Demo()
Dim ws As Worksheet
Dim r As Range
Set ws = ActiveSheet '<~~~ or specify required sheet
Set r = FindFirstEmptyOrBlankCell(ws.Range("F3"))
' literally what was asked for
'r.Formula = "=F3"
' possibly what was actually wanted
r.Formula = "=" & r.Offset(-1, 0).Address(0, 0)
End Sub
Note 1
If IsEmpty(currentRowValue) Or currentRowValue = "" Then is actually redundant. Any value that returns TRUE for IsEmpty(currentRowValue) will also return TRUE of currentRowValue = "" (The reverse does not apply)
From comment can that same Fuction repeat until the last empty cel? I think this is what you mean is to continue to fill blank cells down through the used range
If so, try this
Sub Demo()
Dim ws As Worksheet
Dim cl As Range
Dim r As Range
Set ws = ActiveSheet '<~~~ or specify required sheet
Set cl = ws.Range("F3")
Do
Set r = FindFirstEmptyOrBlankCell(cl)
If r Is Nothing Then Exit Do
r.Formula = "=" & r.Offset(-1, 0).Address(0, 0)
Set cl = r.Offset(1, 0)
Loop
End Sub
Note, I've modified FindFirstEmptyOrBlankCell above to aloow it to return Nothing when it needs to:
Function FindFirstEmptyOrBlankCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty or blank cell
On Error Resume Next ' Allow function to return Nothing
Set FindFirstEmptyOrBlankCell = rng.Cells(StartingAt.Worksheet.Evaluate("Match(True, " & rng.Address & "=""""" & ", 0)"), 1)
End Function
You'll need to change your rowCount, the way you have it, the loop will stop before the first blank row. I believe you should just be able to set use .Formula for the empty cell. Hope this helps:
Sub EmptyCellFillFormula()
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row + 1
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Formula = "=F3"
End If
Next
End Sub
The excel vba macro I have created goes through an entire column and searches each value in the column against another column found on another worksheet. I have a T/F column where I mark down "T" if it is found, "F" if it is not found. However, I feel like the way I am doing it might not be very efficient, as the macro takes about 30 minutes to go through 31,000 rows of values to be searched from another column with about 27,000 number of values.
For a simple illustration, I have included a few images which explains what the macro does.
Initially the T/F column will be empty. Only after executing the macro, would it be filled. I loop through each row in column A and try to find the value against the SearchCol in the next picture.
Here is the vba code I am currently using.
Sub CheckIfValuesExist()
Dim ActiveWS As Worksheet, WS2 As Worksheet
Dim ValueColLetter As String, SearchColLetter As String, TFColLetter As String
Dim LastRow As Long, i As Long
Dim target As Variant, rng As Range
Set ActiveWS = ActiveWorkbook.Worksheets(1)
Set WS2 = ActiveWorkbook.Worksheets(2)
ValueColLetter = "A"
SearchColLetter = "A"
TFColLetter = "B"
LastRow = ActiveWS.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas).Row
For i = 2 To LastRow
target = ActiveWS.Range(ValueColLetter & i).Value
If target <> "" Then
With WS2.Range(SearchColLetter & ":" & SearchColLetter) 'searches all of column A
Set rng = .Find(What:=target, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
ActiveWS.Range(TFColLetter & i).Value = "T" 'value found
Else
ActiveWS.Range(TFColLetter & i).Value = "F" 'value not found
End If
End With
End If
Next i
End Sub
The macro works as intended, I just find it to be slow. Is there any better way to do the same thing but in a quicker manner?
Check Column Against Column
Array Match Range Version
Sub CheckIfValuesExist()
Const cSheet1 As Variant = 1 ' Value Worksheet Name/Index
Const cSheet2 As Variant = 2 ' Search Worksheet Name/Index
Const cFirst As Long = 2 ' First Row
Const cVal As Variant = "A" ' Value Column
Const cSrc As Variant = "A" ' Search Column
Const cTF As Variant = "B" ' Target Column
Const cT As String = "T" ' Found String
Const cF As String = "F" ' Not Found String
Dim RngS As Range ' Search Range
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim LastV As Long ' Value Last Column Number
Dim LastS As Long ' Search Last Column Number
Dim i As Long ' Value/Target Row Counter
Dim dummy As Long ' Match Dummy Variable
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
On Error GoTo ProcedureExit
With ThisWorkbook.Worksheets(cSheet1)
LastV = .Columns(.Cells(1, cVal).Column).Find("*", , -4123, , 2, 2).Row
vntV = .Range(.Cells(cFirst, cVal), .Cells(LastV, cVal))
End With
With ThisWorkbook.Worksheets(cSheet2)
LastS = .Columns(.Cells(1, cSrc).Column).Find("*", , -4123, , 2, 2).Row
Set RngS = .Range(.Cells(cFirst, cSrc), .Cells(LastS, cSrc))
ReDim vntT(1 To UBound(vntV), 1 To 1)
For i = 1 To UBound(vntV)
On Error Resume Next
If vntV(i, 1) <> "" Then
dummy = Application.Match(vntV(i, 1), RngS, 0)
If Err Then
vntT(i, 1) = cF
Else
vntT(i, 1) = cT
End If
End If
On Error GoTo 0
Next
End With
On Error GoTo ProcedureExit
With ThisWorkbook.Worksheets(cSheet1)
.Range(.Cells(cFirst, cTF), .Cells(.Rows.Count, cTF)).ClearContents
.Cells(cFirst, cTF).Resize(UBound(vntT)) = vntT
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Let us assume that data included in Sheet 1.
Try:
Option Explicit
Sub VlookUp()
Dim LastRowSV As Long, LastRowV As Long, Counts As Long
Dim wsName As String
Dim wsListSV As Range, cellSV As Range, wsListV As Range, cellV As Range
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of Search Values
LastRowSV = .Cells(.Rows.Count, "D").End(xlUp).Row
'Find the last row of Values
LastRowV = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the list with the Search Values
Set wsListSV = .Range(Cells(2, 4), Cells(LastRowSV, 4))
'Set the list with the Values
Set wsListV = .Range(Cells(3, 1), Cells(LastRowV, 1))
'Loop each value in Search Values
For Each cellV In wsListV
Counts = Application.WorksheetFunction.CountIf(wsListSV, cellV)
If Counts <> 0 Then
cellV.Offset(0, 1).Value = "T"
Else
cellV.Offset(0, 1).Value = "F"
End If
Next
End With
End Sub
Result:
Why don't you use the MATCH formula?
If your values are in Col A and the search values are at
the cells $F$5:$F$10 the formula is:
=MATCH(A2,$F$5:$F$10,0)
or if you insist on a T/F result:
=IF(ISERROR(MATCH(A2,$F$5:$F$10,0)),"T","F")
Of cause you can insert this formula also with a macro.
I have code that would compare each cell in column A to everything in column B and do this for the number of lines specified.
This was fine when I had a couple hundred lines, but now I am finding with 2000 lines the code is just not going to cut it. Can anyone look at my code and tell me if there are some improvements to be made or if I should scrap it and do it differently.
Sub highlight()
Dim compare As String
Dim i As Integer
Dim comprange As Range
Dim lines As Integer
i = 2
ScreenUpdating = False
Range("a2").Select
lines = Application.InputBox(Prompt:="How many lines need to be compared?",
_
Title:="SPECIFY RANGE", Type:=1)
Do Until IsEmpty(ActiveCell)
If i + 1 > lines Then
Exit Do
End If
Set comprange = Range("A" & i)
comprange.Select
compare = comprange.Value
i = i + 1
Range("B2").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
If ActiveCell.Value = compare Then
ActiveCell.Interior.ColorIndex = 37
ActiveCell.Offset(1, 0).Select
Exit Do
Else
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End If
Loop
Loop
compare = ActiveCell.Value
Set comprange = Selection
Range("a2").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
If ActiveCell.Value = compare Then
comprange.Interior.ColorIndex = 37
ActiveCell.Offset(1, 0).Select
Exit Do
Else
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End If
Loop
End Sub
Try this, it will check ALL your values in column A and if it matches in column B hightlights.
Sub ok()
Dim i, i2 As Long
Dim LastRow, LastRow2 As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ActiveSheet
LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
For i = 1 To LastRow
For i2 = 1 To LastRow2
If Range("A" & i).Value = Range("B" & i2).Value Then
Range("A" & i).Interior.ColorIndex = 37
Range("B" & i2).Interior.ColorIndex = 37
End If
Next
Next
End Sub
Probably the most efficient way to do this is to use the VBA Dictionary object. There's a great article at https://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html that covers a lot of what you need to know.
Below is a function called DuplicatesBetweenLists that will highlight duplicates between any number of different ranges. When calling it, you can specify:
A range to dump a list of duplicates into (pass in an empty range if you don't want a list generated)
Whether or not you want the duplicate items highlighted
A ParamArray (Comma-separated list) of all the ranges you want to check.
So if you wanted to check all three of columns in the image below for entries that occur in each column, and wanted to output a list to cell E1 of any duplicates as well as highlight them in the data, you'd call the function like this:
Sub test()
Dim rOutput As Range
Set rOutput = Range("E1")
DuplicatesBetweenLists rOutput, True, Range("A2:A11"), Range("B2:B11"), Range("C2:C11")
End Sub
...which would give you something like this:
But if you only wanted highlighting and didn't want the identified duplicates output to a range, you'd simply comment out the Set rOutput = Range("E1") line, and pass in an empty range as the first argument.
It is lightning fast compared to a brute force iteration approach: it handled 2 lists containing 2000 items in less than a second (vs 1 minute for the brute force approach). And it handles 2 lists of 200,000 items in just 12 seconds.
And here's the function itself, as well as another function it calls:
Function DuplicatesBetweenLists(rOutput As Range, bHighlight As Boolean, ParamArray Ranges() As Variant)
Dim vRange As Variant
Dim vInput As Variant
Dim dic_A As Object
Dim dic_B As Object
Dim dic_Output As Object
Dim lOutput As Long
Dim lRange As Long
Dim cell As Range
Dim TimeTaken As Date
TimeTaken = Now()
Set dic_A = CreateObject("Scripting.Dictionary")
Set dic_B = CreateObject("Scripting.Dictionary")
Set dic_Output = CreateObject("Scripting.Dictionary")
Set dic_Range = CreateObject("Scripting.Dictionary")
lRange = 1
For Each vRange In Ranges
vInput = vRange
DuplicatesBetweenLists_AddToDictionary vInput, lRange, dic_A, dic_B
Next vRange
If lRange Mod 2 = 1 Then
Set dic_Output = dic_B
Else: Set dic_Output = dic_A
End If
'Write any duplicate items back to the worksheet
If Not rOutput Is Nothing Then
If dic_Output.Count > 0 Then
If dic_Output.Count < 65537 Then
rOutput.Resize(dic_Output.Count) = Application.Transpose(dic_Output.Items)
Else
'The dictionary is too big to transfer to the workheet
'because Application.Transfer can't handle more than 65536 items.
'So well transfer it to an appropriately oriented variant array,
' then transfer that array to the worksheet WITHOUT application.transpose
ReDim varOutput(1 To dic_Output.Count, 1 To 1)
For Each vItem In dic_Output
lOutput = lOutput + 1
varOutput(lOutput, 1) = vItem
Next vItem
rOutput.Resize(dic_Output.Count) = varOutput
End If
End If
End If
'Highlight any duplicates
If bHighlight Then
'Highlight cells in the range that qualify
Application.ScreenUpdating = False
For Each vRange In Ranges
'Set rInput = vRange
vRange.Interior.ColorIndex = 0
For Each cell In vRange
With cell
If dic_Output.Exists(.Value2) Then .Interior.Color = 65535
End With
Next cell
Next vRange
Application.ScreenUpdating = True
TimeTaken = TimeTaken - Now()
Debug.Print Format(TimeTaken, "HH:MM:SS") & "(HH:MM:SS)"
End If
'Cleanup
Set dic_A = Nothing
Set dic_B = Nothing
Set dic_Output = Nothing
End Function
Private Function DuplicatesBetweenLists_AddToDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)
Dim lng As Long
Dim dic_dedup As Object
Dim varItem As Variant
Dim lPass As Long
Set dic_dedup = CreateObject("Scripting.Dictionary")
For lPass = 1 To UBound(varItems, 2)
If lngRange = 1 Then
'First Pass: Just add the items to dic_A
For lng = 1 To UBound(varItems)
If Not dic_A.Exists(varItems(lng, 1)) Then dic_A.Add varItems(lng, 1), varItems(lng, 1)
Next
Else:
' Add items from current pass to dic_Dedup so we can get rid of any duplicates within the column.
' Without this step, the code further below would think that intra-column duplicates were in fact
' duplicates ACROSS the columns processed to date
For lng = 1 To UBound(varItems)
If Not dic_dedup.Exists(varItems(lng, lPass)) Then dic_dedup.Add varItems(lng, lPass), varItems(lng, lPass)
Next
'Find out which Dictionary currently contains our identified duplicate.
' This changes with each pass.
' * On the first pass, we add the first list to dic_A
' * On the 2nd pass, we attempt to add each new item to dic_A.
' If an item already exists in dic_A then we know it's a duplicate
' between lists, and so we add it to dic_B.
' When we've processed that list, we clear dic_A
' * On the 3rd pass, we attempt to add each new item to dic_B,
' to see if it matches any of the duplicates already identified.
' If an item already exists in dic_B then we know it's a duplicate
' across all the lists we've processed to date, and so we add it to dic_A.
' When we've processed that list, we clear dic_B
' * We keep on doing this until the user presses CANCEL.
If lngRange Mod 2 = 0 Then
'dic_A currently contains any duplicate items we've found in our passes to date
'Test if item appears in dic_A, and IF SO then add it to dic_B
For Each varItem In dic_dedup
If dic_A.Exists(varItem) Then
If Not dic_B.Exists(varItem) Then dic_B.Add varItem, varItem
End If
Next
dic_A.RemoveAll
dic_dedup.RemoveAll
Else 'dic_B currently contains any duplicate items we've found in our passes to date
'Test if item appear in dic_B, and IF SO then add it to dic_A
For Each varItem In dic_dedup
If dic_B.Exists(varItem) Then
If Not dic_A.Exists(varItem) Then dic_A.Add varItem, varItem
End If
Next
dic_B.RemoveAll
dic_dedup.RemoveAll
End If
End If
lngRange = lngRange + 1
Next
End Function
First I'm open to do this with an other angle.
I want to count the total hours of work hours estimated, see sheet2. In another sub I've calculated the total work hours (timer tot) with worksheetfunction.sum and timer FRJ/HET with worksheetfunction.sumif. This code doesn't consider overlapping days which means if the dates intersect each other it will calculate 8*2(3,4,5...) (8 hours is average workday in Norway) instead of 8 hours per workday. This will mess up the total amount of time estimated and posibly we will estimate more hours per day than 24 hours :D
I've started this code underneath which I will use to substract the total amount of time and total amout for FRJ and HET.
Code:
Sub Overlapping_WorkDays()
Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range
Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))
For Each cell_name In rng_FRJ_HET
If cell_name = "FRJ" Then
'Count Overlapping networkdays for FRJ
Elseif cell_name = "HET" Then
'Count Overlapping networkdays for HET
End If
Next cell_name
End Sub
Sheet1 screenshot
Sheet2 screenshot
All you need to do is loop through all the date ranges and count them if they haven't already been counted. A Dictionary from the Microsoft Scripting Runtime is well suited for this (you'll need to add a reference in Tools->References).
Function TotalWorkDays(Optional category As String = vbNullString) As Long
Dim lastRow As Long
With Sheet1
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Dim usedDates As Scripting.Dictionary
Set usedDates = New Scripting.Dictionary
Dim r As Long
'Loop through each row with date ranges.
For r = 8 To lastRow
Dim day As Long
'Loop through each day.
For day = .Cells(r, 4).Value To .Cells(r, 5).Value
'Check to see if the day is already in the Dictionary
'and doesn't fall on a weekend.
If Not usedDates.Exists(day) And Weekday(day, vbMonday) < 6 _
And (.Cells(r, 1).Value = category Or category = vbNullString) Then
'Haven't encountered the day yet, so add it.
usedDates.Add day, vbNull
End If
Next day
Next
End With
'Return the count of unique days.
TotalWorkDays = usedDates.Count
End Function
Note that this will work for any arbitrary category found in column 1, or all categories combined if it isn't passed an argument. Sample usage:
Sub Usage()
Debug.Print TotalWorkDays("HET") 'Sample data prints 55
Debug.Print TotalWorkDays("FRJ") 'Sample data prints 69
Debug.Print TotalWorkDays 'Sample data prints 69
End Sub
You can convert this to late bound (and skip adding the reference) by replacing these two lines...
Dim usedDates As Scripting.Dictionary
Set usedDates = New Scripting.Dictionary
...with:
Dim usedDates As Object
Set usedDates = CreateObject("Scripting.Dictionary")
I think if I were doing this, I'd use the Collection object, as it'd save converting names and dates to index id's.
You could create a main collection of names and, for each name, a sub collection of dates whose key is Excel's date serial number. This would make it easy to store the 'used days' and you could either acquire the total day count by using the .Count property or loop through the collection to aggregate a specific Oppgave.
The code would be straight forward as shown below. You could just put this in a module:
Option Explicit
Private mNames As Collection
Public Sub RunMe()
ReadValues
'Get the total days count
Debug.Print GetDayCount("FRJ")
'Or get the days count for one Oppgave
Debug.Print GetDayCount("FRJ", "Malfil tegning form")
End Sub
Private Sub ReadValues()
Dim v As Variant
Dim r As Long, d As Long
Dim item As Variant
Dim dates As Collection
With Sheet1
v = .Range(.Cells(8, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 5).Value2
End With
Set mNames = New Collection
For r = 1 To UBound(v, 1)
'Acquire the dates collection for relevant name
Set dates = Nothing: On Error Resume Next
Set dates = mNames(CStr(v(r, 1))): On Error GoTo 0
'Create a new dates collection if it's a new name
If dates Is Nothing Then
Set dates = New Collection
mNames.Add dates, CStr(v(r, 1))
End If
'Add new dates to the collection
For d = v(r, 4) To v(r, 5)
On Error Resume Next
dates.Add v(r, 2), CStr(d)
On Error GoTo 0
Next
Next
End Sub
Private Function GetDayCount(namv As String, Optional oppgave As String) As Long
Dim dates As Collection
Dim v As Variant
Set dates = mNames(namv)
If oppgave = vbNullString Then
GetDayCount = dates.Count
Else
For Each v In dates
If v = oppgave Then GetDayCount = GetDayCount + 1
Next
End If
End Function
Dictionary approach should be the fastest.
But if your data are not that big you may want to adopt a "string" approach like follows
Function CountWorkingDays(key As String) As Long
Dim cell As Range
Dim iDate As Date
Dim workDates As String
On Error GoTo ExitSub
Application.EnableEvents = False
With Sheet1
With .Range("E7", .Cells(.Rows.Count, "A").End(xlUp))
.AutoFilter field:=1, Criteria1:=key
For Each cell In Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Columns(1))
For iDate = cell.Offset(, 3) To cell.Offset(, 4)
If Weekday(iDate, vbMonday) < 6 Then
If InStr(workDates, cell.value & iDate) <= 0 Then workDates = workDates & cell.value & iDate
End If
Next iDate
Next cell
End With
End With
CountWorkingDays = UBound(Split(workDates, key))
ExitSub:
Sheet1.AutoFilterMode = False
Application.EnableEvents = True
End Function
that you can use in your code as follows
sht2.Cells(2, 7) = CountWorkingDays("FRJ")
sht2.Cells(2, 8) = CountWorkingDays("HET")
As far as I know there is no direct formula to get overlap dates. My approach will be different from yours.
For each unique value in rng_FRJ_HET (i.e. only FRJ and HET as per e.g.)
Create an array with first date and last date
Mark array index with 1 for each date in range start and end date
Sum the array to get actual number of days
Next
So if the dates are repeated still they will mark as 1 in the array for that date.
=====================Added the code=== This will do for any number of names.
Option Explicit
Dim NameList() As String
Sub Overlapping_WorkDays()
Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range
Dim uniqueNames As Range
Dim stDate As Variant
Dim edDate As Variant
Dim Dates() As Integer
Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))
stDate = Application.WorksheetFunction.Min(startDateRng)
edDate = Application.WorksheetFunction.Max(endDateRng)
ReDim NameList(0)
NameList(0) = ""
For Each cell_name In rng_FRJ_HET
If IsNewName(cell_name) Then
ReDim Dates(stDate To edDate + 1)
MsgBox cell_name & " worked for days : " & CStr(GetDays(cell_name, Dates))
End If
Next cell_name
End Sub
Private Function GetDays(ByVal searchName As String, ByRef Dates() As Integer) As Integer
Dim dt As Variant
Dim value As String
Dim rowIndex As Integer
Const COL_NAME = 1
Const COL_STDATE = 4
Const COL_EDDATE = 5
Const ROW_START = 8
Const ROW_END = 19
With Sheet1
For rowIndex = ROW_START To ROW_END
If searchName = .Cells(rowIndex, COL_NAME) Then
For dt = .Cells(rowIndex, COL_STDATE).value To .Cells(rowIndex, COL_EDDATE).value
Dates(CLng(dt)) = 1
Next
End If
Next
End With
GetDays = WorksheetFunction.Sum(Dates)
End Function
Private Function IsNewName(ByVal searchName As String) As Boolean
Dim index As Integer
For index = 0 To UBound(NameList)
If NameList(index) = searchName Then
IsNewName = False
Exit Function
End If
Next
ReDim Preserve NameList(0 To index)
NameList(index) = searchName
IsNewName = True
End Function
I am working through my first VBA book and would appreciate if someone would point me in the right direction. How would I transfer a range of rows into a single cell with carriage returns? I would then like to repeat this action for all ranges in the column.
I think I need to:
find the first cell with a value in the column
verify that the next row is not empty
find the last cell in the range
perform "the operation" on the range
Following up on my comments. here is a very simple way to achieve what you want.
Option Explicit
'~~> You can use any delimiter that you want
Const Delim = vbNewLine
Sub Sample()
Dim rngInput As Range, rngOutput As Range
Application.ScreenUpdating = False
Set rngInput = Range("A1:A5") '<~~ Input Range
Set rngOutput = Range("B1") '<~~ Output Range
Concatenate rngInput, rngOutput
Application.ScreenUpdating = True
End Sub
Sub Concatenate(rng1 As Range, rng2 As Range)
Dim cl As Range
Dim strOutPut As String
For Each cl In rng1
If strOutPut = "" Then
strOutPut = cl.Value
Else
strOutPut = strOutPut & Delim & cl.Value
End If
Next
rng2.Value = strOutPut
End Sub
Within the context of a worksheet-level code, the following will work. Column 2 is hard-coded, so you might want to pass in a value or otherwise modify it to fit your needs.
Dim rng As Range
Set rng = Me.Columns(2)
Dim row As Integer
row = 1
' Find first row with non-empty cell; bail out if first 100 rows empty
If IsEmpty(Me.Cells(1, 2)) Then
Do
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2)) = False Or row = 101
End If
If row = 101 Then Exit Sub
' We'll need to know the top row of the range later, so hold the value
Dim firstRow As Integer
firstRow = row
' Combine the text from each subsequent row until an empty cell is encountered
Dim result As String
Do
If result <> "" Then result = result & vbNewLine
result = result & Me.Cells(row, 2).Text
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2))
' Clear the content of the range
Set rng = Me.Range(Me.Cells(firstRow, 2), Me.Cells(row, 2))
rng.Clear
' Set the text in the first cell
Me.Cells(firstRow, 2).Value2 = result