I have a data dump in Excel that consists of monthly crew member hours worked data. Currently, there are multiple rows of data for the same date.
I want to run a macro that keeps unique names and unique dates but delete rows that have duplicated dates (keep one row for each crew member per date). In the "hours" column, I wish to combine multiple shifts from the same day into one.
Here is my code so far and result.
Sub mcrCombineAndScrubDups()
For Each a In Range("A1", Cells(Rows.Count, "A").End(xlUp))
For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then
a.Offset(0, 6) = a.Offset(0, 6) + a.Offset(r, 6)
a.Offset(r, 0).EntireRow.Delete
r = r - 1
End If
Next r
Next a
End Sub
With the current code, it combines all the hours worked for the entire month into one field rather than a row for each crew member for each date. I know a pivot table can be run but my boss wants more automatic. Thanks!
Related
Background: I'm relatively new to VBA, but I see the value in becoming more comfortable using the skillset.
Goal: Move unorganized data (srce) from one spreadsheet into a different more structured spreadsheet (dest) that can later be uploaded into a software application. I have ~500 of these spreadsheets that need to be migrated, so there is an immense amount of time that could be saved by automating this.
Data: The data is a history of truck maintenance. Periodic maintenance takes place throughout the year with multiple services often performed during a single maintenance routine. Under each routine maintenance, there is a date, # of hours on the vehicle when maintenance is performed, and the type of service performed (consistently column "A").
Data Structure: All service types are contained in column A. Starting in column C & D, I have all of the dates the services performed in 2021 from C11:C34. The # of hours the vehicle has operated at the time of maintenance are contained in cells D11:D34. Subsequently, the dates and # of hours for each maintenance in 2022 are contained in columns E and F.
Challenge: While moving down the rows and before switching to the next column, I need to:
Check for repeat dates
Copy the type of services performed at that date
Paste all of those services performed under a single line item in my destination spreadsheet starting in column T and ending in Column Y (In case ~8 services are performed under a single maintenance routine.)
Question:
How can I complete the above challenge without duplicating entries and keep all services performed on the same date within a single line in my dest spreadsheet?
Below is my code thus far (I've left a comment in the section that is where I intended to craft an answer to my dilemma):
Sub VehicleDataExport()
Application.ScreenUpdating = False
'Set reference cell for output called "dest"
Set dest = Sheets("Dest").Range("A2")
'Initialize counter for destination for how many rows down we are so far
dindx = 0
'Set reference cell for source data called "srce"
Set srce = Sheets("Srce").Range("C11")
'Set reference cell for source for how many columns over we are
cindx = 0
'Set the service type index
Set serviceindex = Sheets("Srce").Range("A11")
'Collect name, vin, and in-service date
vehicle_name = Sheets("Srce").Range("A1")
vehicle_vin = Sheets("Srce").Range("B7")
started_at = Sheets("Srce").Range("B8")
'Go over from anchor column while not empty
While srce.Offset(-1, cindx) <> ""
'set row index so that it can restart everytime you switch columns
rindx = 0
'Cycle down through rows until an "DATE" is found
While srce.Offset(rindx, cindx) <> "DATE"
'Set counter for duplicate index so the program will move through the data while looking for duplicate DATES
duplicateindx = 0
'If statement to determine if something is in the cell - 2nd header row
If srce.Offset(rindx, cindx) > 0 Then
'True Case: copy the date, hours, and service type
service_date = srce.Offset(rindx, cindx)
service_hours = srce.Offset(rindx, cindx + 1)
service_type = serviceindex.Offset(rindx, 0)
meter_void = ""
'Properly label and account for Dot Inspection
If service_type = "DOT Inspection" Then
service_hours = 0
meter_void = True
'secondary_meter_value needs to be 0
'secondary_meter_void needs true
End If
'CHECK FOR DUPLICATE DATES AND COPY THEM TO A SINGLE ROW IN THE DESTINATION
'Paste all of the numbers into a destination row
dest.Offset(dindx, 0) = vehicle_name
dest.Offset(dindx, 1) = vehicle_vin
dest.Offset(dindx, 2) = started_at
'Variable inputs
dest.Offset(dindx, 3) = service_date
dest.Offset(dindx, 13) = service_hours
dest.Offset(dindx, 17) = service_type
dest.Offset(dindx, 14) = meter_void
'Add to both the row and destination indexes
rindx = rindx + 1
dindx = dindx + 1
'If no inspection is found, move down one row
Else: rindx = rindx + 1
'End if statement
End If
'end column specific while loop
Wend
'add two to the column index - account for both the date and hours column
cindx = cindx + 2
'End the initial while loop
Wend
Application.ScreenUpdating = True
End Sub
This really sounds like a job for PowerQuery but if I was to tackle it with VBA I'd use a Scripting.Dictionary. I would also write a small data class that includes all of your service types as Boolean.
I don't fully understand your data structure but some pseudo code might look like this:
Const SRVCECOL As Long = 1
Const HOURSCOL As Long = 2
Function ExtractTransformServiceData(src As Workbook) As Object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim svcDates As Range
Set svcDates = src.Sheets(1).Range("C11:C34")
Dim svcDate As Range
For Each svcDate in svcDates
Dim tsd As TruckServiceData
If dict.Exists(svcDate.Value) Then
Set tsd = dict.Item(svcDate.Value)
Else
Set tsd = New TruckServiceData
dict.Add svcDate.Value, tsd
End If
tsd.SetHoursForService( _
svcDate.Offset(0, SRVCECOL).Value, _
svcDate.Offset(0, HOURSCOL).Value)
Next svcDate
Set ExtractTransformServiceData = dict
End Sub
I am trying to restructure inside one drive using automate a function, but not sure if multi header table can be restructured. Thank you in advance for your help.
I want to restructure it in this format -
Customer
You can loop through the dates in 1st row and create a nested loop which goes through the customers one by one and get the values according to the actual column and row. You should save the result on a new sheet.
Sub Format_Table()
lastRowOnNewFormatSheet = 2 'last empty row on newSheet
'Loop through the columns with step 3
For i = 2 To Cells(1, Columns.Count).End(xlToLeft).Column Step 3
'Loop through the rows at every column
For j = 3 To Cells(Rows.Count, 1).End(xlUp).Row
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 1).Value = Sheets("oldFormat").Cells(j, 1) 'customer name
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 2).Value = Sheets("oldFormat").Cells(1, i) 'date
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 3).Value = Sheets("oldFormat").Cells(j, i) 'budget
Sheets("newFormat").Cells(lastRowOnNewFormatSheet, 4).Value = Sheets("oldFormat").Cells(j, i + 1) 'actual
lastRowOnNewFormatSheet = lastRowOnNewFormatSheet + 1 'update last empty row on newSheet
Next j
Next i
End Sub
I would like to create an excel template for warehouse. In this template are integrated warehouse, sellings and invoices.
I already wrote a code that transfers data to sellings every time I create an invoice and click a button. I would like to integrate in my code function that can do corrections in my warehouse i.e. when I fill an invoice I put items ID, description, amount and a price. After I click a button I want the items amount in the warehouse sheet to decreased by the same amount as in invoice.
The biggest issue for me was how to write a code that takes information from invoice sheet (ID and items amount), look for exact matches in the warehouse sheet and in the warehouse sheet column "I"(stock) decrease stock with the same amount.
sheet1 - name sheet "warehouse". ID in the column "C"; stock - column "I"; data starts from row "4"
sheet3 - name sheet "invoice". ID in the merged column "A""B"(column 1); amount that I sell in the merged column "S""T""U" (column 4); data starts from row 15 as you can see in the code below.
My code that transfers data to sellings (sheet2). I need to integrate function into this code without creating another button.
Sub Button4_Click()
Dim x As Long
Dim erow As Long
'Calculate starting rows
x = 15
With Worksheets("Sellings")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
With Worksheets("Invoice")
Do While .Cells(x, 1) <> ""
'The next line copies values to Sheet2
Worksheets("Sellings").Range("A" & erow & ":Z" & erow).Value = .Range("A" & x & ":Z" & x).Value
'increment row counters
x = x + 1
erow = erow + 1
Loop
End With
End Sub
I'm trying to find a way to automatically insert a column based on a date. Here's some context:
The top row of my spreadsheet (Row 1) contains dates in the format yyyy/mm/dd
The dates aren't day-by-day; they are weekly (i.e. one cell may say 2015/09/21 the next will say 2015/09/28 and the next will say 2015/10/05) so this can change from year to year
I need to find a way to automatically insert ONE column at the end of each quarter and TWO columns at the end of each half (i.e. ONE column between March and April, TWO between June and July, ONE between September and October, and TWO between December and January)
So far, this is what I am using to traverse the top row and see if the date is before October but after September. The dates start from cell I1. Although the code executes without any error, it does not actually do anything. Any help you all can offer will be appreciated.
With Sheets("Sheet1")
Range("I1").Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value < DateValue("2015/10/1") And ActiveCell.Offset(0, 1).Value > DateValue("2015/9/28") Then
Range(ActiveCell).EntireColumn.Insert
End If
ActiveCell.Offset(0, 1).Select
Loop
End With
I think you're off to a good start with your method. You should be able to just check if the day of the month is less than or equal to 7. That should indicate the first week in a month. If that month is 4 or 10, insert a column. If it's 1 or 7, insert two.
Dim r As Range
Set r = Range("I1")
Do Until IsEmpty(r)
If Day(r) <= 7 Then
Select Case Month(r)
Case 4, 10
r.EntireColumn.Insert
Case 1, 7
r.Resize(1, 2).EntireColumn.Insert
End Select
End If
Set r = r.Offset(0, 1)
Loop
Going strictly on a change in months bewteen two cell in the header row may be the easiest logic.
Sub insert_quarter_halves()
Dim c As Long
With Worksheets("Sheet8") 'set this worksheet reference properly!
For c = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
If (Month(.Cells(1, c - 1).Value2) = 3 And Month(.Cells(1, c).Value2) = 4) Or _
(Month(.Cells(1, c - 1).Value2) = 9 And Month(.Cells(1, c).Value2) = 10) Then
.Cells(1, c).EntireColumn.Insert
ElseIf (Month(.Cells(1, c - 1).Value2) = 6 And Month(.Cells(1, c).Value2) = 7) Or _
(Month(.Cells(1, c - 1).Value2) = 12 And Month(.Cells(1, c).Value2) = 1) Then
.Cells(1, c).Resize(1, 2).EntireColumn.Insert
End If
Next c
End With
End Sub
When inserting columns, always travel from right to left or you risk skipping an entry that was pushed forward.,
I have a puzzle I've been trying to solve for ages now, but it's quite simply beyond me.
I have a spreadsheet with 3 columns. Column A is instructor ID numbers, Column B is their course Start date and Column C is their course end date. There are multiple courses for each instructor ID.
I'm basically trying to answer the question, what is the maximum number of courses this instructor is teaching at any given time.
Essentially, I need to find, for each ID number, the number of maximum, concurrent, overlapping date ranges.
The trouble is, while I know how to find overlapping date ranges, I don't know how to count the number of concurrent courses.
Eg.
Instructor 115 has the following date ranges listed:
9/10/13 / 11/04/13
9/17/13 / 11/11/13
11/05/13 / 12/30/13
11/12/13 / 1/20/14
While the 11/05/13 course overlaps with both the 9/17/13 course and the 11/12/13 course, they do not overlap with each other... so this instructor is only teaching a maximum of 2 courses at any time.
Is there a way to write a function that will return the highest number of concurrent overlapping date ranges for each ID?
Edit not form OP to transfer details from a comment:
I can solve this geometrically, but I don't know how to do that in a VBA function (I'm still very new to programming). If I were to solve this outside of code, I would create a table for each ID making a column for every day. I'd then create a row for each date range, marking a 1 in each column that range overlaps with. then I’d sum the total overlaps for each day. Then I’d use a simple MAX function to return the highest number of consecutive overlaps. Is there a way to do this inside of a function without having Excel physically draw out these tables?
Using VBA, assuming Column A contains your start dates, and column B contains your end dates, and assuming your data starts in row 1 and there are no blank rows in your data, the below sub will do what you outlined in your comment:
Sub getMaxConcurrent()
'get minimum date (startDate)
Dim startDateRange
Set startDateRange = Range("A1", Range("A1").End(xlDown))
Dim startDate As Date
startDate = WorksheetFunction.Min(startDateRange)
'get maximum date (endDate)
Dim endDateRange
Set endDateRange = Range("B1", Range("B1").End(xlDown))
Dim endDate As Date
endDate = WorksheetFunction.Max(endDateRange)
'get date range (dateInterval)
Dim dateInterval As Integer
dateInterval = DateDiff("d", startDate, endDate)
'Create daily table header
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Dim x As Integer
For x = 0 To dateInterval
Dim dateVal As Date
dateVal = DateAdd("d", startDate, x)
Cells(1, 3 + x).Value = dateVal
Next
'Fill in daily table
Dim y As Integer
y = 2
Dim startDateValue As Date
startDateValue = Cells(y, 1).Value
Do Until IsEmpty(Cells(y, 1).Value)
For x = 3 To dateInterval + 3
If (Cells(y, 1).Value <= Cells(1, x).Value) Then
If (Cells(y, 2).Value >= Cells(1, x).Value) Then
Cells(y, x).Value = 1
Else
Cells(y, x).Value = 0
End If
Else
Cells(y, x).Value = 0
End If
Next
y = y + 1
Loop
'sum up each day
For x = 3 To dateInterval + 3
Cells(y, x).Value = WorksheetFunction.Sum(Range(Cells(2, x).Address & ":" & Cells(y - 1, x).Address))
Next
MsgBox ("Max concurrent courses: " & WorksheetFunction.Max(Range(Cells(y, 3).Address & ":" & Cells(y, x).Address)))
End Sub
If you have data down to row 1000 then this "array formula" will give the maximum number of concurrent courses for an Instructor ID in E2
=MAX(COUNTIFS(A:A,E2,B:B,"<="&B$2:C$1000,C:C,">="&B$2:C$1000))
confirmed with CTRL+SHIFT+ENTER
Let's assume there is only one instructor and you have start and end dates in A1:B4.
Copy A1:A4 to A7:A10, copy B1:b4 to A11:a14 (right under it). Select A7:A14, hit Sort (on data tab) and "remove duplicates". You have a list unique list of dates in ascending order. Let's assume there were no duplicates (as in your example), your of date is same A7:a14. Select it copy, and paste spacial with transpose to C5.
At this point You have start and end dates in A1:B4 and list of uniqe dates in C5:J5. Put formula =IF(AND($A1<=C$5,C$5<=$B1),1,0) in C1 and copy it to C1:J4.
put formula =SUM(C1:C4) in C6 and copy it to C6:J6.
Maximum number in C6:j6 is your maximum concurrent courses for this instructor