Using SUMIFS to add time duration always gives 00:00:00 - vba

Sub Add_sumf()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
For Each y In bb.Range("A:A")
On Error GoTo Label
If UCase(bb.Cells(j, "A").Value) <> "" Then
cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), aa.Range("B:B"), UCase(bb.Cells(1, k).Value), aa.Range("G:G"), UCase(bb.Cells(j, "A").Value))
bb.Cells(j, k).Value = TimeValue(cellDate1)
cellDate1 = TimeValue("00:00:00")
bb.Cells(j, k).NumberFormat = "[h]:mm:ss"
On Error GoTo Label
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
I am using above code to add time duration based upon value of two other columns but I always get 00:00:00 as result.
if i use below code i get the answer but its too slow very slow
Sub add_it_time()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
'MsgBox bb.Cells(1, k).Value
For Each y In bb.Range("A:A")
On Error GoTo Label
' MsgBox UCase(bb.Cells(j, "A").Value)
If UCase(bb.Cells(j, "A").Value) <> "" Then
For Each x In aa.Range("F:F")
On Error Resume Next
If UCase(aa.Cells(i, "B").Value) = UCase(bb.Cells(j, "A").Value) Then
' MsgBox aa.Cells(i, "F").Text
' total = total + Int(get_Second(aa.Cells(i, "F").Text))
If UCase(aa.Cells(i, "G").Value) = UCase(bb.Cells(1, k).Value) Then
'MsgBox aa.Cells(i, "F").Text
cellDate1 = cellDate1 + TimeValue(aa.Cells(i, "F").Value)
End If
End If
i = i + 1
Next
i = 3
On Error GoTo Label
bb.Cells(j, k).NumberFormat = "h:mm:ss"
bb.Cells(j, k).Value = WorksheetFunction.Text(cellDate1, "[hh]:mm:ss")
total = 0
cellDate1 = 0
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
The source column which contains date is of general formatt
I am new to VBA macros

UPDATED SOLUTION:
After discussion in chat with OP it was decided that pure formula solution is fine - below are formulas / actions to do on the separate sheet starting A1:
Row A will be resulting table header: in A1 I added Agent Name / Release Code, and starting B1 there's a list of all available Release Code values (easily got using Remove Duplicates).
I defined the following named ranges for the simplicity and effectiveness (since initial data is NOT static): AgentNames=OFFSET('Agent State'!$B$2,0,0,COUNTA('Agent State'!$B:$B)-1,1) - this will return the range of names on the initial sheet excluding the header; TimeInStateData=OFFSET(AgentNames,0,4) and ReleaseCodes=OFFSET(AgentNames,0,5) as shifted AgentNames range.
In column A we should obtain the list of names, which should be unique, so select in column A any number of cells which is NOT less that number of unique names - for the sample I used A2:A51, and type that formula: =IFERROR(INDEX(AgentNames,SMALL(IF(MATCH(AgentNames,AgentNames,0)=ROW(INDIRECT("1:"&ROWS(AgentNames))),MATCH(AgentNames,AgentNames,0),""),ROW(INDIRECT("1:"&ROWS(AgentNames))))),"") and press CTRL+SHIFT+ENTER instead of usual ENTER - this will define a Multicell ARRAY formula and will result in curly {} brackets around it (but do NOT type them manually!).
B2: =IF(OR($A2="",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))=0),"",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))) - normal formula, which will return empty value for either empty name or zero time.
Copy formula from B2 to the whole table.
Remarks:
Resulting range for the sum of time values should be formatted as Time.
If the list of names should be expanded in the future - repeat step 3 for the new range, but do NOT drag the formula down - this will result in You cannot change part of an array error.
Sample file: https://www.dropbox.com/s/quudyx1v2fup6sh/AgentsTimeSUM.xls
INITIAL ANSWER:
Perhaps that's too simple and obvious, but at a glance I don't understand why you have that line of code:
cellDate1 = TimeValue("00:00:00")
right after your SUMIFS: cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), ...
Try to remove the first one where you assign zeros to cellDate1.

Related

Auto scheduling

I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job

VBA: Finding max value of sum among continuous numbers

I have a table which goes from A1 to ALL1 (1000 values), I have to find the max value of consecutive numbers for example if I had these six values:
4 37 -12 2 3 -1, the max would be 41 taken from the first two numbers. If it was
-6 -14 6 15 22 -9, it would be 43 (from 6, 15, 22).
I have to do this in VBA from randomly generated numbers (figured that part out so it's good), but can't figure out this part and then I have to return the position of the first and last value in my sequence. So please some help would be greatly appreciated as I'm not quite a VBA wizard.
Thank you :)
Consider the below example:
Sub Test()
Dim arrValues() As Variant
Dim dblTop As Double
Dim lngFirst As Long
Dim lngLast As Long
Dim i As Long
Dim j As Long
Dim dblSum As Double
Dim arrResult() As Variant
arrValues = Range("A1:ALL1")
dblTop = arrValues(1, 1)
lngFirst = 1
lngLast = 1
For i = 1 To 1000
dblSum = 0
For j = i To 1000
dblSum = dblSum + arrValues(1, j)
If dblSum > dblTop Then
lngFirst = i
lngLast = j
dblTop = dblSum
End If
Next
Next
Debug.Print "Max value: " & dblTop
Debug.Print "First index: " & lngFirst
Debug.Print "Last index: " & lngLast
arrResult() = Array()
For k = lngFirst To lngLast
ReDim Preserve arrResult(UBound(arrResult) + 1)
arrResult(UBound(arrResult)) = arrValues(1, k)
Next
Debug.Print "Sequence: " & Join(arrResult, " + ")
End Sub
For the set of the values e. g. as in the question
It returns the following output
Just to be a little different, and because I did the work before my weekend blew up, here is a function that will return a range:
Function MAXSUM(r As Range) As Range
Dim i&, j&
Dim rng As Range
Dim sm As Double
Dim ws As Worksheet
Set ws = ActiveSheet
sm = r.Item(1) + r.Item(2)
For i = 1 To r.Cells.Count - 1
For j = i + 1 To r.Cells.Count
With ws
If WorksheetFunction.Sum(.Range(r(i), r(j))) > sm Then
Set rng = .Range(r(i), r(j))
sm = WorksheetFunction.Sum(.Range(r(i), r(j)))
End If
End With
Next j
Next i
Set MAXSUM = rng
The beauty of this is:
1.It returns the range of the max sum.
2.It is not dependent on being in the first row, it can be a column, a row, or multiples of each. It will look left to right first then top to bottom of the range.
3.It can be called from vba and/or directly as a UDF in the worksheet(see below)
To call from vba:
Sub getmax()
Dim rng As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set rng = MAXSUM(ws.Range("A1 :AAL1"))
Debug.Print rng.Address 'gets the address of range
Debug.Print WorksheetFunction.Sum(rng) 'gets the sum of the range
End Sub
This just shows a few things, but because it returns a range it is possible to do anything one can do with a given range.
To call from the worksheet directly:
To get the sum:
=SUM(MAXSUM(*YourRange*))
To get the range:
First Cell:
=ADDRESS(ROW(MAXSUM(*YourRange*)),COLUMN(MAXSUM(*YourRange*)))
Last cell:
=ADDRESS(ROW(MAXSUM(*YourRange*))+ROWS(MAXSUM(*YourRange*))-1,COLUMN(MAXSUM(*YourRange*))+COLUMNS(MAXSUM(*YourRange*))-1)
Full Address:
=ADDRESS(ROW(MAXSUM(*YourRange*)),COLUMN(MAXSUM(*YourRange*)))&":"&ADDRESS(ROW(MAXSUM(*YourRange*))+ROWS(MAXSUM(*YourRange*))-1,COLUMN(MAXSUM(*YourRange*))+COLUMNS(MAXSUM(*YourRange*))-1)
Basically the formula MAXSUM(*YourRange*) works like a named range, and anything you can do with a named range you can do with this.
One note: This currently assumes that the user wants the sum of at least two numbers and therefore if the entire range is negative, or only one consecutive positive it will return the sum of the two consecutive cells that give the highest sum. To make it so it will return the highest one cell in the case of all negative or only one consecutive positive cells then remove the +1 and -1 from the beginning of the for loops.
This will do it:
Sub msa()
Dim j&, cur&, max&, ndx&, ndx1&, ndx2&, a: ndx = 1
a = [A1:ALL1]
For j = 1 To UBound(a, 2)
cur = cur + a(1, j)
Select Case True
Case cur > max: max = cur: ndx2 = j: ndx1 = ndx
Case cur <= 0: cur = 0: ndx = j + 1
End Select
Next
MsgBox max & vbLf & ndx1 & vbLf & ndx2
End Sub
My answer is based on Kadane's algorithm which has a time complexity of O(n), which is dramatically more efficient than the brute force O(n*n) time complexity of the other answer.
.
UPDATE
To handle the edge case of all negative numbers as well, you can use this version:
Sub msa()
Dim j&, k&, m&, n&, cur&, max&, ndx&, ndx1&, ndx2&, a: ndx = 1: m = -2 ^ 31
a = [A1].CurrentRegion.Resize(1)
For j = 1 To UBound(a, 2)
k = a(1, j)
If k > m Then m = k: n = j
cur = cur + k
Select Case True
Case cur > max: max = cur: ndx2 = j: ndx1 = ndx
Case cur <= 0: cur = 0: ndx = j + 1
End Select
Next
If max = 0 Then max = m: ndx1 = n: ndx2 = n
MsgBox max & vbLf & ndx1 & vbLf & ndx2
End Sub

My macro is showing runtime error 1004. Please check

I am getting the 1004 error when running. The error is at this line:
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
What I want to do is to select the sheet (CTRYNAME) and then search through columns 5,7,9 etc and format the numbers as done in the code.
Public Sub MoM_Check()
Dim inti As Integer
Dim intj As Integer
Dim k As Integer
Dim mnth As Integer
Dim currSALE As Double
Dim prevSALE As Double
Dim diffpercent As Double
Dim CTRYname As String
Dim x As Integer
Dim column As String
'Find Difference percentage between sales of 24 common months in present month's extarct and previous month's extract
For n = 1 To 13
Application.SheetsInNewWorkbook = 4
Set wkbTemp = Workbooks.Add
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
'Open a temporary workbook to do all the Calculations
'First the current month's extract is copied to the first sheet
'We now copy sheets for range from wkbout to wkbtemp using usedrange
wkbCurr.Sheets(CTRYname).Activate
wkbCurr.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet1").Range("A1").PasteSpecial
wkbprev.Sheets(CTRYname).Activate
wkbprev.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet2").Range("A1").PasteSpecial
'open the Previous month's Main Extract file as given in the lookup tab. This data is pasted on sheet2 of temporary workbook.
'This sheet helps us to compare the country channels in current month's extract with the previous Month's Extract.
'So the same process is followed for this sheet and similarly we get the country channels from the previous month's extract and paste them on 'sheet3
'Prevcnt contains the number of country channels in the previous month's extract
k = 1
For mnth = 0 To 22
currSALE = wkbTemp.Sheets("Sheet1").Range("AB10").Offset(0, mnth).Value
prevSALE = wkbTemp.Sheets("Sheet2").Range("AC10").Offset(0, mnth).Value
If prevSALE = 0 And currSALE <> 0 Then
diffpercent = 1
ElseIf prevSALE = 0 And currSALE = 0 Then
diffpercent = 0
Else: diffpercent = (currSALE - prevSALE) / prevSALE
End If
If diffpercent > 0.01 Or diffpercent < -0.01 Then
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Incorrect"
Exit For
Else
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Correct"
k = k + 1
wkbRaw.SaveAs Filename:=strOutputQCPath & "Errorlog.xlsx"
wkbRaw.Close
End If
Next mnth
For x = 1 To 15
If x = 1 Or x = 2 Or x = 3 Or x = 4 Or x = 6 Or x = 9 Or x = 10 Or x = 11 Or x = 13 Then
GoTo Name
Else
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
If wkbCurr.Sheets(CTRYname).Range(column & x).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Range(column & x).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = "<-999%"
End If
End If
End If
Name:
Next x
wkbTemp.Close savechanges:=False
Set wkbTemp = Nothing
Next n
End Sub
Please help!
You haven't given the string "column" a value, which is why you're getting error 1004 on that line.

Excel Loop through list,transpose and create a matrix based on cell content

I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub

Remove selected numbers from a comma separated list management in Excel?

This might be a little tricky, even with VBA...
I have comma separated lists in cells based on start times over 5 minutes intervals but I need to remove times that are only 5 apart.
The numbers are text, not time at this point. For example, one list would be 2210, 2215, 2225, 2230, 2240 (the start times).
In this case, 2215 and 2230 should be removed but I also need to remove the opposite numbers (i.e.,2210 and 2225) in other cases (the end times).
Someone helped me with my specs:
A cell contains times: t(1), t(2), t(3), ... t(n). Starting at time t(1), each value in the list is examined. If t(x) is less than 6 minutes after t(x-1) delete t(x) and renumber t(x+1) to t(n).
Input:
2210, 2215, 2225, 2230, 2240
Output:
column1: 2210
column2: 2240
This does what I think you require.
Option Explicit
Sub DeleteSelectedTimes()
Dim RowCrnt As Long
RowCrnt = 2
Do While Cells(RowCrnt, 1).Value <> ""
Cells(RowCrnt, 1).Value = ProcessSingleCell(Cells(RowCrnt, 1).Value, 1)
Cells(RowCrnt, 2).Value = ProcessSingleCell(Cells(RowCrnt, 2).Value, -1)
RowCrnt = RowCrnt + 1
Loop
End Sub
Function ProcessSingleCell(ByVal CellValue As String, ByVal StepFactor As Long) As String
Dim CellList() As String
Dim CellListCrntStg As String
Dim CellListCrntNum As Long
Dim InxCrnt As Long
Dim InxEnd As Long
Dim InxStart As Long
Dim TimeCrnt As Long ' Time in minutes
Dim TimeLast As Long ' Time in minutes
CellList = Split(CellValue, ",")
If StepFactor = 1 Then
InxStart = LBound(CellList)
InxEnd = UBound(CellList)
Else
InxStart = UBound(CellList)
InxEnd = LBound(CellList)
End If
CellListCrntStg = Trim(CellList(InxStart))
If (Not IsNumeric(CellListCrntStg)) Or InStr(CellListCrntStg, ".") <> 0 Then
' Either this sub-value is not numeric or if contains a decimal point
' Either way it cannot be a time.
ProcessSingleCell = CellValue
Exit Function
End If
CellListCrntNum = Val(CellListCrntStg)
If CellListCrntNum < 0 Or CellListCrntNum > 2359 Then
' This value is not a time formatted as hhmm
ProcessSingleCell = CellValue
Exit Function
End If
TimeLast = 60 * (CellListCrntNum \ 100) + (CellListCrntNum Mod 100)
For InxCrnt = InxStart + StepFactor To InxEnd Step StepFactor
CellListCrntStg = Trim(CellList(InxCrnt))
If (Not IsNumeric(CellListCrntStg)) Or InStr(CellListCrntStg, ".") <> 0 Then
' Either this sub-value is not numeric or if contains a decimal point
' Either way it cannot be a time.
ProcessSingleCell = CellValue
Exit Function
End If
CellListCrntNum = Val(CellListCrntStg)
If CellListCrntNum < 0 Or CellListCrntNum > 2359 Then
' This value is not a time formatted as hhmm
ProcessSingleCell = CellValue
Exit Function
End If
TimeCrnt = 60 * (CellListCrntNum \ 100) + (CellListCrntNum Mod 100)
If Abs(TimeCrnt - TimeLast) < 6 Then
' Delete unwanted time from list
CellList(InxCrnt) = ""
Else
' Current time becomes Last time for next loop
TimeLast = TimeCrnt
End If
Next
CellValue = Join(CellList, ",")
If Left(CellValue, 1) = "," Then
CellValue = Mid(CellValue, 2)
CellValue = Trim(CellValue)
End If
Do While InStr(CellValue, ",,") <> 0
CellValue = Replace(CellValue, ",,", ",")
Loop
ProcessSingleCell = CellValue
End Function
Explanation
Sorry for the lack of instructions in the first version. I assumed this question was more about the technique for manipulating the data than about VBA.
DeleteSelectedTimes operates on the active worksheet. It would be easy to change to work on a specific worksheet or a range of worksheets if that is what you require.
DeleteSelectedTimes ignores the first row which I assume contains column headings. Certainly my test worksheet has headings in row 1. It then processes columns A and B of every row until it reaches a row with an empty column A.
ProcessSingleCell has two parameters: a string and a direction. DeleteSelectedTimes uses the direction so values in column A are processed left to right while values in column B are processed right to left.
I assume the #Value error is because ProcessSingleCell does not check that the string is of the format "number,number,number". I have changed ProcessSingleCell so if the string is not of this format, it does change the string.
I have no clear idea of what you do or do not know so come back with more questions as necessary.
Still not clear on your exact requirements, but this might help get you started....
Sub Tester()
Dim arr
Dim out As String, x As Integer, c As Range
Dim n1 As Long, n2 As Long
For Each c In ActiveSheet.Range("A1:A10")
If InStr(c.Value, ",") > 0 Then
arr = Split(c.Value, ",")
x = LBound(arr)
out = ""
Do
n1 = CLng(Trim(arr(x)))
n2 = CLng(Trim(arr(x + 1)))
'here's where your requirements get unclear...
out = out & IIf(Len(out) > 0, ", ", "")
If n2 - n1 <= 5 Then
out = out & n1 'skip second number
x = x + 2
Else
out = out & n1 & ", " & n2 'both
x = x + 1
End If
Loop While x <= UBound(arr) - 1
'pick up any last number
If x = UBound(arr) Then
out = out & IIf(Len(out) > 0, ", ", "") & arr(x)
End If
c.Offset(0, 1).Value = out
End If
Next c
End Sub
Obviously many ways to skin this cat ... I like to use collections for this sort of thing:
Private Sub PareDownList()
Dim sList As String: sList = ActiveCell ' take list from active cell
Dim vList As Variant: vList = Split(sList, ",") ' convert to variant array
' load from var array into collection
Dim cList As New Collection
Dim i As Long
For i = 0 To UBound(vList): cList.Add (Trim(vList(i))): Next
' loop over collection removing unwanted entries
' (in reverse order, since we're removing items)
For i = cList.Count To 2 Step -1
If cList(i) - cList(i - 1) = 5 Then cList.Remove (i)
Next i
' loop to put remaining items back into a string fld
sList = cList(1)
For i = 2 To cList.Count
sList = sList + "," + cList(i)
Next i
' write the new string to the cell under the activecell
ActiveCell.Offset(1) = "'" + sList ' lead quote to ensure output cell = str type
End Sub
' If activecell contains: "2210, 2215, 2225, 2230, 2240"
' the cell below will get: "2210,2225,2240"
Note: this sample code should be enhanced w some extra validation & checking (e.g. as written assumes all good int values sep by commas & relies in implicit str to int conversions). Also as written will convert "2210, 2215, 2220, 2225, 2230, 2240" into "2210, 2040" - you'll need to tweak the loop, loop ctr when removing an item if that's not what you want.