VB to Merge Rows with Multiple Criteria

[WheezyE]

Hello, we are getting data exported out of a Time Sheet from multiple Foremen. These Foremen might get the same employee or that employee might go to several different Foremen during the week. It must be a Macro and not a Pivot Table since we need to manipulate the data for different purposes. I am having a real hard time trying to figure out how to write a Macro to Look through several rows and compare each employee's name and if they are the same, it then needs to compare each day worked (could be 6 or 7 days and there is 2 cells per day because the can work 2 different jobs on 1 day) and if the job numbers are the same add the time together then clear the cell or delete the entire row if there is nothing left on it. I hope that makes sense, I apologize if it is a little confusing.

Now here is were is gets a little more complicated, because it can't just compare row 5 to row 6 then row 6 to row 7. Row 5, 6, and 7 could all be the same employee, but the job # could be blank on certain columns and if row 6 column AF is blank but row 5 and 7 have the same job # the comparison will only look at row 5, then 6, then 7 and they will not be merged.

For my test example here are the rows and columns I need to compare then merge.
Names start at D3 to D82, row 3 to 82, column 4
MondayJob1 at V3 to V82, row 3 to 82, column 22
MondayJob2 at W3 to W82, row 3 to 82, column 23
TuesdayJob1 at X3 to X82, row 3 to 82, column 24
TuesdayJob2 at Y3 to Y82, row 3 to 82, column 25
WednesdayJob1 at Z3 to Z82, row 3 to 82, column 26
WednesdayJob2 at AA3 to AA82, row 3 to 82, column 27
ThursdayJob1 at AB3 to AB82, row 3 to 82, column 28
ThursdayJob2 at AC3 to AC82, row 3 to 82, column 29
FridayJob1 at AD3 to AD82, row 3 to 82, column 30
FridayJob2 at AE3 to AE82, row 3 to 82, column 31
SaturdayJob1 at AF3 to AF82, row 3 to 82, column 32
SaturdayJob2 at AG3 to AG82, row 3 to 82, column 33
SundayJob1 at AH3 to AH82, row 3 to 82, column 34
SundayJob2 at AI3 to AI82, row 3 to 82, column 35

The Time values are in H through U, 8 through 21 and same row range of 3 to 82

Please let me know if you would like me to provide any additional information or the excel file. Thank you in advance for any time spent on this I really appreciate it.

 

[Warship]

Are Blank jobs merged or kept seperate?
Are the time values in H thru U Time Quantities? Formatted how?
Is H the time for Mon1... I for Mon2... J for Tues1... etc.?
What if you ever have different employees with the same name?

 

[WheezyE]

Blank jobs are merged.
Are the time values in H thru U Time Quantities? No
Formatted how? Just numbers, e.g. 1 or 1.5
Is H the time for Mon1... I for Mon2... J for Tues1... etc.? Yes
What if you ever have different employees with the same name? The names will never be exactly the same.

 

[WheezyE]

I might have not read this correctly "Is H the time for Mon1... I for Mon2... J for Tues1... etc.?"

H the time for Mon1
I the time for Mon2
J the time for Tue1
K the time for Tue2

and so on. Two cells for 1 day H & I for Monday, but Monday is split into Mon1 & Mon2. I hope clears it up a bit.

 

[Warship]

try:

Sub MergeTimeSheet()
    Dim shData As Worksheet
    Dim rgData As Range, rgName As Range, fnd As Range
    Dim LR As Long, sR As Long, eR As Long
    Dim n As Long, r As Long, c As Integer
    Dim dTime As Single
    Dim sName As String, arrName As Variant
    Dim sBlankJob As String, add1 As String
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    'determine data range
    Set shData = Sheets(1) 'Sheets("Sheet1") 'change as needed
    LR = shData.Cells(Rows.Count, "D").End(xlUp).Row
    Set rgData = shData.Range("D3:AI" & LR)
    
    'mark blank jobs
    sBlankJob = "-||-"
    For r = 1 To rgData.Rows.Count
        For c = 5 To 18
            If rgData.Cells(r, c) <> "" And rgData.Cells(r, c).Offset(, 14) = "" Then
                rgData.Cells(r, c).Offset(, 14) = sBlankJob
            End If
        Next c
    Next r
    
    'create name array
    rgData.Sort Key1:=rgData.Columns(1)
    For n = 1 To rgData.Rows.Count
        If InStr(sName, rgData.Cells(n, 1)) = 0 Then
            sName = sName & "|" & rgData.Cells(n, 1)
        End If
    Next n
    sName = Mid(sName, 2)
    arrName = Split(sName, "|")
    
    'process names
    For n = 0 To UBound(arrName)
        Set fnd = rgData.Columns(1).Find(arrName(n), rgData.Cells(rgData.Rows.Count, 1), , xlWhole)
        If Not fnd Is Nothing Then
            sR = fnd.Row
            eR = Application.WorksheetFunction.CountIf(rgData.Columns(1), arrName(n)) + sR - 1
            Set rgName = Range("D" & sR & ":AI" & eR)
            For r = rgName.Rows.Count To 1 Step -1
                For c = 5 To 18
                    If rgName.Cells(r, c) <> "" Then
                        Set fnd = rgName.Columns(c + 14).Find(rgName.Cells(r, c).Offset(, 14), , , xlWhole)
                        If Not fnd Is Nothing Then
                            add1 = fnd.Address
                            Do
                                dTime = dTime + fnd.Offset(, -14)
                                fnd.Offset(, -14).ClearContents
                                If fnd.Address <> add1 Then fnd.ClearContents
                                Set fnd = rgName.Columns(c + 14).FindNext(fnd)
                            Loop While fnd.Address <> add1
                            fnd.Offset(, -14) = dTime
                            dTime = 0
                        End If
                    Else
                        If Application.WorksheetFunction.CountBlank(rgName.Rows(r)) = 31 Then
                            rgName.Rows(r).Delete xlUp
                            Exit For
                        End If
                    End If
                Next c
            Next r
        End If
    Next n
    
    'delete blank job markers
    shData.Cells.Replace What:=sBlankJob, Replacement:="", LookAt:=xlWhole
    
    'combine same name rows
    For n = 0 To UBound(arrName)
        Set fnd = rgData.Columns(1).Find(arrName(n), rgData.Cells(rgData.Rows.Count, 1), , xlWhole)
        If Not fnd Is Nothing Then
            sR = fnd.Row
            eR = Application.WorksheetFunction.CountIf(rgData.Columns(1), arrName(n)) + sR - 1
            Set rgName = Range("D" & sR & ":AI" & eR)
            For r = rgName.Rows.Count To 2 Step -1
                With rgName
                    .Rows(r).Copy
                    .Rows(1).PasteSpecial SkipBlanks:=True
                    .Rows(r).Delete xlUp
                End With
            Next r
        End If
    Next n
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[WheezyE]

Great, thank you Warship, I really appreciate your help. I have changed the code to work on the sheet I am using, which is sheet10. When I run the code I am getting a run-time error'1004' "This operation requires the merged cells to be identically sized." When I click on Debug it highlights the first row on
'create name array
rgData.Sort Key1:=rgData.Columns(1)

I don't have any merged cells, and all the rows and columns are set to the same size. Not sure what the issue is. And the full name is in Column 4.

I don't think I mentioned this and I apologize for that. My data range is A3:AO I have headers in row 2 and I am using row 1 for column #'s. I have First and Last in Col D, then I break the names up into Last then First in different Cells. Last is in Col B and First is in C. Then I recombined them in Col A as Last, First and sort them by last name.

I hope this information helps. I will continue to try different things to get it to work. Again, thank you for your time and effort.

 

[Warship]

Let's be sure a "Merge" didn't happen accidently...
Try selecting all cells then unmerge

why col#'s row 1?

 

[Warship]

Your OP explained there would be 0 to 2 jobs/day.
The WB sent shows Emp#9 having 3 jobs on Tues.
I suggest adding additional Cols to accommodate more than 2 jobs.
In other words, Tues1, Tues2, Tues3 etc.
This way you'll follow the same logic rather than "watching" for an exception
It may be a PITA now but I think you'll be better off in the long run.
I couldn't take the time to understand the flow of your data, so I'm not sure what all it would take to add additional jobs.
Maybe a bunch it looks like, but I still think probably worth the effort.
If you add the additional jobs this will still work w/ some minor changes.
Let me know.

Anyway...

Sub MergeTimeSheet()
    Dim shData As Worksheet
    Dim rgData As Range, rgName As Range, fnd As Range
    Dim LR As Long, sR As Long, eR As Long
    Dim n As Long, r As Long, c As Integer
    Dim dTime As Single
    Dim sName As String, arrName As Variant
    Dim sBlankJob As String, add1 As String
    Dim sTestRgAdd As String
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    'determine data range
    Set shData = Sheets("Sheet10") 'change as needed
    LR = shData.Cells(Rows.Count, "A").End(xlUp).Row
    Set rgData = shData.Range("A3:AO" & LR)
    
    'mark blank jobs
    sBlankJob = "-||-"
    For r = 1 To rgData.Rows.Count
        For c = 8 To 21
            If rgData.Cells(r, c) <> "" And rgData.Cells(r, c).Offset(, 14) = "" Then
                rgData.Cells(r, c).Offset(, 14) = sBlankJob
            End If
        Next c
    Next r
    
    'create name array
    For n = 1 To rgData.Rows.Count
        If InStr(sName, rgData.Cells(n, 4)) = 0 Then
            sName = sName & "|" & rgData.Cells(n, 4)
        End If
    Next n
    sName = Mid(sName, 2)
    arrName = Split(sName, "|")
    
    'process names
    'rgData.Sort Key1:=rgData.Columns(1)  'not needed since data already sorted & will only work on sorted data
    For n = 0 To UBound(arrName)
        Set fnd = rgData.Columns(4).Find(arrName(n), rgData.Cells(rgData.Rows.Count, 4), , xlWhole)
        If Not fnd Is Nothing Then
            sR = fnd.Row
            eR = Application.WorksheetFunction.CountIf(rgData.Columns(4), arrName(n)) + sR - 1
            Set rgName = Range("A" & sR & ":AO" & eR)
            For r = rgName.Rows.Count To 1 Step -1
                For c = 8 To 21
                    If Application.WorksheetFunction.CountBlank(rgName.Rows(r).Offset(, 7).Resize(1, 14)) = 14 Then
                        rgName.Rows(r).Delete xlUp
                        Exit For
                    End If
                    If rgName.Cells(r, c) <> "" Then
                        Set fnd = rgName.Columns(c + 14).Find(rgName.Cells(r, c).Offset(, 14), , , xlWhole)
                        If Not fnd Is Nothing Then
                            add1 = fnd.Address
                            Do
                                dTime = dTime + fnd.Offset(, -14)
                                fnd.Offset(, -14).ClearContents
                                If fnd.Address <> add1 Then fnd.ClearContents
                                Set fnd = rgName.Columns(c + 14).FindNext(fnd)
                            Loop While fnd.Address <> add1
                            fnd.Offset(, -14) = dTime
                            dTime = 0
                        End If
                    End If
                Next c
            Next r
        End If
'
        'combine rows
        'this will not work when you have 3 or more jobs on the same day
        'I think it does what you asked when there is 2 or less jobs/day
'        On Error Resume Next
'        sTestRgAdd = rgName.Address
'        If Err.Number = 0 Then
'            For r = rgName.Rows.Count To 2 Step -1
'                With rgName
'                    .Rows(r).Copy
'                    .Rows(1).PasteSpecial SkipBlanks:=True
'                    .Rows(r).Delete xlUp
'                End With
'            Next r
'        End If
'        On Error GoTo 0
'
    Next n
    
    'delete blank job markers
    shData.Cells.Replace What:=sBlankJob, Replacement:="", LookAt:=xlWhole
    
    [A1].Select 'park cursor
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[WheezyE]

Excellent Warship, I really appreciate your help. It does work, but not the way I anticipated. Perhaps my explanation wasn't clear enough. For example on the wb I uploaded on Sheet10. When you merge, I know it is only for 2 job#'s per day, that is fine. If they happen to work the third job that will need to stay on a separate Row. But, for Rows 5, 6, 7 it merges the Sat Job and adds the time (which is what needed to happen), since it is the same job. But here is what I though it would do. Since Row 7 only had the 1 job on Sat, and the same Job on Sat for Row 5 I though it would merge 7 to 5 then delete 7. Instead it merged 5 to 7 then deleted row 5's cells (which is fine, but backwards). I am trying to consolidate the # of rows an employee has. Each Row represents 1 Time Sheet, each employee needs to be on 1 time sheet, unless they work the third job for the day.

Then for Row 20 and 21 it did not merge or consolidate it at all.

Now if I UN-Comment your " 'On Error Resume Next statement " it does consolidate everything. Everything is combined. Even if there are different Job #'s, (which you mentioned it will not work if you have 3 different job #'s), But that is exactly what I am trying to accomplish. To keep the third Job on a separate row.

I hope this makes sense, and I apologize for any inconvenience or if I misconstrued anything. Thank you again I really do appreciate it. Please contact me if you would like me to clear anything up. But it does work, just not the way I had envisioned.

 

[Warship]

Thanks for the feedback.
It seemed to me that when 'combine rows' were ran as well, the third job was overwriting the other job that day without regard to job#'s.
No need to apologize at all - no worries here, just glad to help!
Thanks too for your expressed appreciation - you're very welcome.