Sub ConsolidateData()
' hiker95, 03/31/2015, ME845570
Dim w1 As Worksheet, wr As Worksheet
Dim lr As Long, r As Long, nr As Long, n As Long, lc As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1") ''<-- change the raw data sheet name here
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results" ''<-- you can change the results sheet name here
Set wr = Sheets("Results") ''<-- you can change the results sheet name here
With wr
.UsedRange.Clear
.Cells(1, 1).Resize(, 6).Value = w1.Cells(1, 1).Resize(, 6).Value
End With
With w1
.Activate
lr = .Cells(Rows.Count, 1).End(xlUp).Row
With .Range("A2:D" & lr)
.Value = Evaluate(Replace("If(Len(@),Proper(@),"""")", "@", .Address))
End With
With .Range("E2:E" & lr)
.Value = Evaluate(Replace("If(Len(@),Upper(@),"""")", "@", .Address))
End With
With .Range("H2:H" & lr)
.Formula = "=A2&B2&C2&D2&E2&F2"
.Value = .Value
End With
For r = 2 To lr
nr = wr.Cells(wr.Rows.Count, "A").End(xlUp).Row + 1
n = Application.CountIf(.Columns(8), .Cells(r, 8).Value)
If n = 1 Then
wr.Cells(nr, 1).Resize(, 7).Value = .Cells(r, 1).Resize(, 7).Value
ElseIf n > 1 Then
wr.Cells(nr, 1).Resize(, 6).Value = .Cells(r, 1).Resize(, 6).Value
wr.Cells(nr, 7).Resize(, r + n - 1).Value = Application.Transpose(.Range("G" & r & ":G" & r + n - 1))
End If
r = r + n - 1
Next r
.Range("H2:H" & lr).ClearContents
End With
With wr
.Activate
lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
On Error Resume Next
With Range(Cells(2, 7), Cells(nr, lc))
.SpecialCells(xlCellTypeConstants, xlErrors).ClearContents
End With
lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
.Range(.Cells(2, 7), .Cells(nr, lc)).NumberFormat = "m/d/yyyy"
With .Cells(1, 7).Resize(, lc - 6)
.Formula = "=""CallDate"" & Column() - 6"
.Value = .Value
End With
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
