Option Explicit
Sub clarka9_V2()
' hiker95, 03/25/2013
' http://www.mrexcel.com/forum/excel-questions/692848-divide-conquer-2.html
Dim wD As Worksheet, wR As Worksheet
Dim r As Long, lr As Long, sr As Long, er As Long, nr As Long
Dim lrra As Long, lrrd As Long, n As Long
Dim m As Long, sm As Long, em As Long
Dim y As Long, sy As Long, ey As Long
Application.ScreenUpdating = False
Set wD = Worksheets("Data")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=wD).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
With wR.Cells(1, 1).Resize(, 4)
.Value = [{"First Name","Last","Date","Level"}]
.Font.Bold = True
End With
lr = wD.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr Step 1
If wD.Cells(r, 3) = "" Or wD.Cells(r, 4) = "" Then
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
If wD.Cells(r, 3) = "" Then
wR.Cells(nr, 3) = wD.Cells(r, 4)
wR.Cells(nr, 4) = wD.Cells(r, 5)
ElseIf wD.Cells(r, 4) = "" Then
wR.Cells(nr, 3) = wD.Cells(r, 3)
wR.Cells(nr, 4) = wD.Cells(r, 5)
End If
ElseIf Year(wD.Cells(r, 3)) = Year(wD.Cells(r, 4)) And Month(wD.Cells(r, 3)) = Month(wD.Cells(r, 4)) Then
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(2, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
wR.Cells(nr, 3) = wD.Cells(r, 3)
wR.Cells(nr, 4).Resize(2).Value = wD.Cells(r, 5).Value
wR.Cells(nr + 1, 3) = wD.Cells(r, 4)
ElseIf Year(wD.Cells(r, 3)) = Year(wD.Cells(r, 4)) And Month(wD.Cells(r, 3)) <> Month(wD.Cells(r, 4)) Then
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
m = Month(wD.Cells(r, 4)) - Month(wD.Cells(r, 3))
wR.Cells(nr, 1).Resize(m + 1, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
wR.Cells(nr, 3) = wD.Cells(r, 3)
wR.Cells(nr, 4).Value = wD.Cells(r, 5)
With wR.Cells(nr + 1, 3).Resize(m - 1)
.FormulaR1C1 = "=MONTH(R[-1]C)+1&""/""&DAY(R[-1]C)&""/""&YEAR(R[-1]C)"
.Value = .Value
End With
wR.Cells(nr + m, 3) = wD.Cells(r, 4)
wR.Cells(nr, 4).Resize(m + 1).Value = wD.Cells(r, 5)
ElseIf Year(wD.Cells(r, 3)) <> Year(wD.Cells(r, 4)) Then
sm = Month(wD.Cells(r, 3))
sy = Year(wD.Cells(r, 3))
em = Month(wD.Cells(r, 4))
ey = Year(wD.Cells(r, 4))
For y = sy To ey Step 1
If y = sy Then
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 3).Value = wD.Cells(r, 1).Resize(, 3).Value
For m = sm + 1 To 12 Step 1
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
With wR.Cells(nr, 3)
.FormulaR1C1 = "=MONTH(R[-1]C)+1&""/""&DAY(R[-1]C)&""/""&YEAR(R[-1]C)"
.Value = .Value
End With
Next m
ElseIf y > sr And y < ey Then
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
With wR.Cells(nr, 3)
.FormulaR1C1 = "=MONTH(1)&""/""&DAY(R[-1]C)&""/""&YEAR(R[-1]C)+1"
.Value = .Value
End With
For m = 2 To 12 Step 1
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
With wR.Cells(nr, 3)
.FormulaR1C1 = "=MONTH(R[-1]C)+1&""/""&DAY(R[-1]C)&""/""&YEAR(R[-1]C)"
.Value = .Value
End With
Next m
ElseIf y = ey Then
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
With wR.Cells(nr, 3)
.FormulaR1C1 = "=MONTH(1)&""/""&DAY(R[-1]C)&""/""&YEAR(R[-1]C)+1"
.Value = .Value
End With
For m = 2 To em - 1 Step 1
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
With wR.Cells(nr, 3)
.FormulaR1C1 = "=MONTH(R[-1]C)+1&""/""&DAY(R[-1]C)&""/""&YEAR(R[-1]C)"
.Value = .Value
End With
Next m
nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wR.Cells(nr, 1).Resize(, 2).Value = wD.Cells(r, 1).Resize(, 2).Value
wR.Cells(nr, 3).Value = wD.Cells(r, 4).Value
End If
Next y
lrra = wR.Cells(Rows.Count, 1).End(xlUp).Row
lrrd = wR.Cells(Rows.Count, 4).End(xlUp).Row
wR.Range("D" & lrrd + 1 & ":D" & lrra) = wD.Cells(r, 5)
End If
Next r
lr = wR.Cells(Rows.Count, 1).End(xlUp).Row
wR.Range("C2:C" & lr).NumberFormat = "m/d/yyyy"
wR.Cells.EntireColumn.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub
