And thanks in advance for any help you can provide. I'm fairly new to VBA and this is outside of my current capability.
Ok, so I have raw data that is broken up by date and time in 30 minute intervals (Columns A, B). I have built a loop to find a specific segment (lines of data using Start Time, and Stop Time). What I am having issues with is pulling a timeframe for multiple days. The code is pulling the entire segment from start to end time, regardless of the date. So I end up with a large chunk of data that needs to be trimmed down.
Here is the code I'm using currently.
Key: *A2 = Start Date, *B2 = Start Time, *C2 = End Date, *D2 = End Time.
'============================================
' Date/Time lookup in Adjusted Table
'============================================
Sheets("Allotments (ADJ)").Select
i = 1
Do Until Cells(i, 1) = ""
If Cells(i, 1) = Sheets("macros").Range("a2") Then
Do Until Cells(i, 1) <> Sheets("macros").Range("a2")
If Cells(i, 2) = Sheets("macros").Range("b2") Then
startrow = i
End If
i = i + 1
Loop
End If
i = i + 1
Loop
i = 1
Do Until Cells(i, 1) = ""
If Cells(i, 1) = Sheets("macros").Range("c2") Then
Do Until Cells(i, 1) <> Sheets("macros").Range("c2")
If Cells(i, 2) = Sheets("macros").Range("d2") Then
endrow = i
End If
i = i + 1
Loop
End If
i = i + 1
Loop
Sheets("Allotments (ADJ)").Range("a" & startrow & ":l" & endrow).Copy
Sheets("macros").Select
Range("c3").Select
ActiveSheet.Paste
CutCopyMode = False
Is there a way I can modify this to grab only a desgnated timeframe for each day, if I'm trying to pull from multiple date range?
After tinkering with it for a long time and making the variables clearer I was able to get a working version.
StartDate = DateValue(StartDate)
EndDate = DateValue(EndDate)
Sheets("Allotments (ADJ)").Select
If StartDate = EndDate Then
datestart = 2
Do Until Range("A" & datestart) = ""
If Sheets("Allotments (ADJ)").Range("A" & datestart).Value = StartDate Then
StartTimerow = datestart
Do Until Range("B" & StartTimerow).Value = StartTime
StartTimerow = StartTimerow + 1
Loop
Endtimerow = StartTimerow
Do Until Range("B" & Endtimerow).Value = EndTime
Endtimerow = Endtimerow + 1
Loop
Exit Do
End If
datestart = datestart + 1
Loop
Sheets("Allotments (ADJ)").Range("a" & StartTimerow & ":N" & Endtimerow).Copy
Sheets("Macros").Select
Range("C1").Select
Range("c" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
CutCopyMode = False
End Sub
Related
I am trying to fetch data from a webpage. My VBA code is as below
m = 0
For Each htmlele1 In doc.getElementsByClassName("resultsbranch")
m = m + 1
companyname = htmlele1.getElementsByTagName("h2")
Address = htmlele1.getElementsByTagName("span")
If Address.getAttribute("itemprop") = "myaddress" Then
Range("D" & i).Value = companyname.innerText + "," + Address.innerText
End If
Teliphone = htmlele1.getElementsByClassName("teldata")
If Teliphone.getAttribute("itemprop") = "tel" Then
Range("E" & i).Value = Teliphone.innerText
End If
'i = i + 1
'Debug.Print i
Next
On the first iteration, values are get inserted to columns D,E
on second iteration I want to insert data To F,H .
On 3 rd iteration I,J
On 4th iteration K,L
So on up to nth iteration
How can i do this ?
Instead of:
Range("D" & i).Value
Range("E" & i).Value
Use:
Cells(i, (m*2 + 3)).Value
Cells(i, (m*2 + 4)).Value
Or use another counter... As you like... Hope that helps.
I'm trying to write a code that will look at the city a call takes place in and then assigns a team in a city to remedy the call. There are 7 team locations and the teams are assigned by which team has the lightest workload. If two teams have the same workload it is assigned to the team in the nearest city.
I'm having problems thinking about how a loop would calculate the minimum workload but then also take into account there being more than one min and then decide to use the nearest location of minimums.
right now I have a sheet that has the date of the call and the number of days to completion for each call. I have an array (N4:N10) that displays the last completion date for each team location. Right now my loop is just taking the minimum of those completion dates and assigning the corresponding team to the call and then incrementing the last completion date by the expected number of days to complete the last call, but it's not taking into account there being more than one minimum.
Sub TeamAssignment()
Dim lastRow As Integer
Dim i As Integer
lastRow = Worksheets("Calc").Range("E" & Rows.Count).End(xlUp).Row
Dim SmallestWorkload As Date
Dim TeamAssigned As String
For i = 3 To lastRow
'find smallest workload and put into sheet
SmallestWorkload = Application.WorksheetFunction.Min(Sheets("Calc").Range("N4:N10"))
TeamAssigned = SmallestWorkload.Offset(0, 1).Value
Range(i, "F").Value = TeamAssigned
If TeamAssigned = "Miami" Then
MIAcompletion = SmallestWorkload + Range(i, "I").Value
Range("N9").Value = MIAcompletion
ElseIf TeamAssigned = "Jacksonville" Then
JAXcompletion = SmallestWorkload + Range(i, "I").Value
Range("N5").Value = JAXcompletion
ElseIf TeamAssigned = "New Smyrna Beach" Then
NSBcompletion = SmallestWorkload + Range(i, "I").Value
Range("N6").Value = NSBcomplation
ElseIf TeamAssigned = "Ocala" Then
OCALAcompletion = SmallestWorkload + Range(i, "I").Value
Range("N7").Value = OCALAcompletion
ElseIf TeamAssigned = "St. Petersburg" Then
SPcompletion = SmallestWorkload + Range(i, "I").Value
Range("N8").Value = SPcompletion
ElseIf TeamAssigned = "Gainesville" Then
GNVcompletion = SmallestWorkload + Range(i, "I").Value
Range("N4").Value = GNVcompletion
Else
PSLcompletion = SmallestWorkload + Range(i, "I").Value
Range("N10").Value = PSLcompletion
End If
Next i
End Sub
The below is an example of how one might try to look at two conditions in a loop using vba code.
You will have to then assign the variables at the end to the cells you wish them to go in, and add code to update the final team that was chosen, but perhaps it gives you some ideas.
Sub TeamAssignment()
' Assuming column N has the workload date, column O has the Team, and column P has the distance in miles
Dim lastRow As Integer
Dim i As Integer
lastRow = Worksheets("Calc").Range("E" & Rows.Count).End(xlUp).Row
Dim TeamAssigned As String, SmallestWorkload As Date, ClosestTeam As Double
' Choose the first team to begin with
SmallestWorkload = Range("N3").Value: TeamAssigned = Range("O3").Value: ClosestTeam = Range("P3").Value
'find smallest workload and put into sheet
For i = 3 To lastRow
Select Case Range("N" & i).Value
Case Is < SmallestWorkload
' If we find a smaller workload, then assign it to this team
SmallestWorkload = Range("N" & i).Value: TeamAssigned = Range("O" & i).Value: ClosestTeam = Range("P" & i).Value
Case Is = SmallestWorkload
' If the workload is the same, then determine if it should be assigned based on the distance
If Range("P" & i).Value < ClosestTeam Then _
SmallestWorkload = Range("N" & i).Value: TeamAssigned = Range("O" & i).Value: ClosestTeam = Range("P" & i).Value
End Select
Next i
End Sub
I have four columns, loop over two of the columns using nested do while loops, and then two if statements to act as constraints. If the two if statements are passed, revalue (paste is an option too), two new cells to the values of the cells that were checked using the index on the first loop, and another two new cells to the values of the cells that were checked using the index on the nested loop.
code:
Dim i
Dim j
i = 1
j = 1
Do Until IsEmpty(Range("BE" & i))
Do Until IsEmpty(Range("BH" & j))
If Cells(i, "BE").Value = Cells(j, "BH").Value Then
If (Cells(j, "BG").Value - Cells(i, "BF")) < TimeValue("1:00:00") Then
'This is not correctly filtering, dates/time are in
' mm/dd/yy hh:mm format
Range("BJ" & i).Value = Range("BE" & i).Value
Range("Bk" & i).Value = Range("BF" & i).Value
Range("BL" & i).Value = Range("BG" & j).Value
Range("BM" & i).Value = Range("BH" & j).Value
End If
End If
j = j + 1
Loop
i = i + 1
j = 1
Loop
End Sub
What it does:
It does almost everything correctly. The issue is that it does NOT correctly check if the difference in time between cells BG(j) and BF(i) < 60 minutes. Whether using:
If (Cells(j, "BG").Value - Cells(i, "BF")) * 1440 < 60 Then
or
IF (Cells(j, "BG").Value - Cells(i, "BF")) < TimeValue("1:00:00") Then
values that are 5 hours in difference are being seen as true and passing through the if statement.
Try adding j = 1 just after i = i + 1
So I have a column of notes in excel that has notes like "01/16 14:38 ATND [Notes from Dealer/Distributor] JR" and "01/16 14:14 ATND [Notes from Company] JR2" and "01/16 14:14 ATND [Notes from Company] TLO The item is back ordered"
As you can see after the bracket sign, there is a two letter or three letter codes of three different variations, JR, JR2 and TLO. I wrote a program that only distinguishes between JR and TLO but wont extract the code if its numbered for example, JR and JR2. If someone can help me with this, I would greatly appreciate it.
Sub G_ExtractCodes()
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Dim i As Long
Dim NoteCodes As Range
For i = LR To 2 Step -1
Set NoteCodes = Range("O" & i)
If InStr(NoteCodes, "JR") >= 1 Then
Cells(i, 20) = "JR"
ElseIf InStr(NoteCodes, "JR2") >= 1 Then
Cells(i, 20) = "JR2"
ElseIf InStr(NoteCodes, "TLO") >= 1 Then
Cells(i, 20) = "TLO"
End If
Next i
End Sub
Your first condition in the If statement is more restrictive than the first ElseIf clause, so any instance of "JR2" will be caught by the first test (only finds "JR", and the ElseIf are not evaluated).
Flip your logic, and I think this should fix it:
If InStr(NoteCodes, "JR2") >= 1 Then
Cells(i, 20) = "JR2"
ElseIf InStr(NoteCodes, "JR") >= 1 Then
Cells(i, 20) = "JR"
ElseIf InStr(NoteCodes, "TLO") >= 1 Then
Cells(i, 20) = "TLO"
End If
Alternatively, you can parse out the codes like:
Dim codeValue as String
Dim bracketLocation as Integer
For i = LR To 2 Step -1
Set NoteCodes = Range("O" & i)
'finds the position of the right bracket
bracketLocation = Instr(NoteCodes, "]")
'Lops off any characters up to & including the right square bracket
codeValue = Trim(Mid(NoteCodes, bracketLocation + 1))
'removes any text that appears *after* the code value, if any
If Instr(codeValue, " ") > 0 Then
codeValue = Left(codeValue, Instr(codeValue, " "))
End If
Cells(i, 20).Value = codeValue
'clear out the variable
codeValue = vbNullString
Next
Sub G_ExtractCodes()
sn=cells(1).currentregion.columns(1).offset(,15)
for j=1 to ubound(sn)
If InStr(sn(j,1), "JR") Then
Cells(j, 20) = iif(instr(sn(j,1),"JR2"),"JR2","JR")
ElseIf InStr(sn(j,1), "TL") Then
Cells(j, 20) = iif(instr(sn(j,1),"TL0"),"TL0","TL")
End If
Next
End Sub
I'm trying to set up an Excel (2010) spreadsheet to calculate overtime for employees from a spreadsheet generated by the time clock. The report from the time clock gives total hours only. Overtime can be calculated by separating hours into regular hours and OT hours. Anything over 10 hours in a day counts as OT hours. Once you have hit 40 REGULAR hours (not including OT), all hours past that point are counted as OT. Then all OT is added up. If you never hit 40 regular hours, but still have daily OT, then daily OT is used.
I feel like this shouldn't be too terribly difficult. I've tried using some conditional formulas to calculate and break out the OT, but haven't been able to come up with anything that works in all cases and allows the process to be automated. I've included a link below to an example spreadsheet generated by the time clock. Is it possible to break out the OT the way I want without using VBA?
Example Spreadsheet
Please let me know if you need any additional information. At least some ideas of where to start would be very welcome, or if there are other posts that address similar matters I could use to get going (I haven't been able to find any that quite work in this situation). Thanks!
I needed a little brain challenge this morning so I decided to help you out. This is how I solved your problem.
Turn on developer
tab
Open the Visual Basic Editor ALT+F11 or
Insert a one standard Module
Copy and Paste the below code into that Module
Option Explicit
Sub OTHours()
Sheets(2).Activate
Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row).ClearContents
Dim c As Collection
Set c = New Collection
Dim e As Collection
Set e = New Collection
On Error GoTo RowHandler
Dim i As Long, r As Range
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("C" & i)
c.Add r.Row, r.Offset(0, -2) & "£" & r
Next i
For i = 1 To c.Count
If i <> c.Count Then
Dim j As Long
j = c.Item(i)
Dim m As Merged
Set m = New Merged
m.Name = Range("A" & c.Item(i))
m.Dates = Range("C" & c.Item(i))
Do Until j = c.Item(i + 1)
m.Hours = m.Hours + Range("F" & j)
m.Row = j
j = j + 1
Loop
Else
Dim k As Long
k = c.Item(i)
Set m = New Merged
m.Name = Range("A" & c.Item(i))
m.Dates = Range("C" & c.Item(i))
Do Until IsEmpty(Range("A" & k))
m.Hours = m.Hours + Range("F" & k)
m.Row = k
k = k + 1
Loop
End If
e.Add m
Next i
For i = 1 To e.Count
'Debug.Print e.Item(i).Name, e.Item(i).Dates, e.Item(i).Hours, e.Item(i).Row
Range("G" & e.Item(i).Row) = IIf(e.Item(i).Hours - 10 > 0, e.Item(i).Hours - 10, vbNullString)
Next i
PrintOvertime e
Exit Sub
RowHandler:
Resume Next
End Sub
Private Sub PrintOvertime(e As Collection)
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In Sheets
If StrComp(ws.Name, "Overtime Only", vbTextCompare) = 0 Then ws.Delete
Next
Application.DisplayAlerts = True
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Overtime Only"
Set ws = Sheets("Overtime Only")
With ws
Dim i As Long
.Range("A1") = "Applicant Name"
.Range("B1") = "Date"
.Range("C1") = "OT hours"
.Range("D1") = "Week Number"
For i = 1 To e.Count
If (e.Item(i).Hours - 10 > 0) Then
.Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1) = e.Item(i).Name
.Range("B" & .Range("B" & Rows.Count).End(xlUp).Row + 1) = e.Item(i).Dates
.Range("C" & .Range("C" & Rows.Count).End(xlUp).Row + 1) = e.Item(i).Hours - 10
End If
Next i
.Columns.AutoFit
End With
PrintWeekNum
End Sub
Private Sub PrintWeekNum()
Dim ws As Worksheet
Set ws = Sheets("Overtime Only")
With ws
Dim i As Long
For i = 2 To .Range("C" & Rows.Count).End(xlUp).Row
Dim r As String
r = .Range("B" & i).Text
.Range("D" & i) = WorksheetFunction.WeekNum(Right(r, 4) & "-" & Left(r, 2) & "-" & Right(Left(r, 5), 2))
Next i
End With
End Sub
Now insert a Class Module
Copy and Paste the below code to it
Option Explicit
Public Name As String
Public Dates As Date
Public Hours As Double
Public Row As Long
Rename your Class Module to Merged
Note: you need to turn on the Properties Window, either click View on the menu bar then select Properties Window or hit F4
Select the Class Module and rename it from Class1 to Merged
Go back to the spreadsheet view and select Time Detail Sheet
Hit ALT+F8
or
select Macros on the Developer tab and hit Run
The OVERTIME results will be filled in to your Time Details Sheet column G
Also
There will be a new sheet added named Overtime Only which will have a table of all people who did extra hours. (and only people who earned Overtime)
The results will look like
Time Detail
Overtime Only
I took the answer from #mehow and modified it a bit to take weekly overtime into account. I'm not sure if it's the cleanest or most efficient way to go about it, but it gets the job done.
I created an additional class module, "DlyHrs," which holds hrs for a single day for a single employee. Each person has a collection of these DlyHrs objects, so their total regular and OT hours for the week can be tracked.
Class Module "DlyHrs" -
Option Explicit
Public Day As Date
Public totHrs As Double
Public regHrs As Double
Public otHrs As Double
Public row As Long
I modified the Class Module "Merged" as so -
Option Explicit
Public Name As String
Public Hrs As Collection
Public regHrs As Double
Public otHrs As Double
Public totHrs As Double
So far, it seems to be working, and breaking out all daily and weekly overtime correctly. Here is the entire code for the macro -
Option Explicit
Sub OTHours()
ThisWorkbook.Sheets("Time Detail").Activate
Range("T2:T" & Range("T" & Rows.Count).End(xlUp).row).ClearContents
Range("T1") = "OT"
Dim c As Collection
Set c = New Collection
Dim e As Collection
Set e = New Collection
On Error GoTo RowHandler
Dim i As Long, r As Range
For i = 2 To Range("A" & Rows.Count).End(xlUp).row
Set r = Range("H" & i)
c.Add r.row, r.Offset(0, -7) & "£" & r
Next i
'store name of previous person to know when to add new person to collection
Dim prev As String
prev = vbNullString
For i = 1 To c.Count
Dim j As Long
j = c.Item(i)
Dim curr As String
curr = Range("A" & j)
'if not dealing with a new person, add hours to existing person
'rather than creating new person
If curr = prev Then GoTo CurrentPerson
Dim m As Merged
Set m = New Merged
m.Name = Range("A" & c.Item(i))
Set m.Hrs = New Collection
CurrentPerson:
Dim curHrs As DlyHrs
Set curHrs = New DlyHrs
curHrs.Day = Range("H" & c.Item(i))
If i <> c.Count Then
'Add up hours column
Do Until j = c.Item(i + 1)
curHrs.totHrs = curHrs.totHrs + Range("K" & j)
curHrs.row = j
j = j + 1
Loop
Else
Do Until IsEmpty(Range("A" & j))
curHrs.totHrs = curHrs.totHrs + Range("K" & j)
curHrs.row = j
j = j + 1
Loop
End If
'break out regular and OT hours and add to current person
If m.regHrs = 40 Then 'all hrs to OT
curHrs.otHrs = curHrs.totHrs
m.totHrs = m.totHrs + curHrs.totHrs
m.otHrs = m.otHrs + curHrs.totHrs
ElseIf m.regHrs + curHrs.totHrs > 40 Then 'approaching 40
curHrs.regHrs = 40 - m.regHrs
curHrs.otHrs = curHrs.totHrs - curHrs.regHrs
m.totHrs = m.totHrs + curHrs.totHrs
m.regHrs = m.regHrs + curHrs.regHrs
m.otHrs = m.otHrs + curHrs.otHrs
ElseIf curHrs.totHrs > 10 Then 'not approaching 40, but daily ot
curHrs.otHrs = curHrs.totHrs - 10
curHrs.regHrs = curHrs.totHrs - curHrs.otHrs
m.totHrs = m.totHrs + curHrs.totHrs
m.regHrs = m.regHrs + curHrs.regHrs
m.otHrs = m.otHrs + curHrs.otHrs
Else 'no daily or weekly ot
m.totHrs = m.totHrs + curHrs.totHrs
m.regHrs = m.regHrs + curHrs.totHrs
End If
If curHrs.otHrs <> 0 Then
Range("T" & curHrs.row) = curHrs.otHrs
End If
m.Hrs.Add curHrs
Dim nextPerson As String
nextPerson = Range("A" & j)
'check if next name is a new person. if so, add current person to collection
If curr <> nextPerson Then
e.Add m
End If
prev = curr
Next i
Exit Sub
RowHandler:
Resume Next
End Sub