VBA Code to Add row headings, delete rows based on value

[GMLee]

Excel 2007
Windows XP

Happy Monday!

I would appreciate help in creating a macro to format my report from looking like this:
[TABLE="class: grid, width: 415"]
<tbody>[TR]
[TD]Employee Name[/TD]
[TD]Activity Name[/TD]
[/TR]
[TR]
[TD]Nathan[/TD]
[TD]Manager: Ron[/TD]
[/TR]
[TR]
[TD="align: right"]7/22/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Actvity1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Actvity1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/23/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/24/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Actvity1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Gina[/TD]
[TD]Manager: Jewel[/TD]
[/TR]
[TR]
[TD="align: right"]7/23/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1x1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/24/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/25/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Meeting[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/26/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]Morena[/TD]
[TD]Manager: Sean[/TD]
[/TR]
[TR]
[TD="align: right"]7/23/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Activity3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]1x1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/24/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/25/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Meeting[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Phone[/TD]
[/TR]
</tbody>[/TABLE]

To looking like this:
Rows that are blank, or contain Phone and or Break are being deleted
[TABLE="class: grid, width: 192"]
<tbody>[TR]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[TD="width: 64"]Activity Name[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/22/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/22/12[/TD]
[TD="width: 64"]Actvity1[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/22/12[/TD]
[TD="width: 64"]Actvity1[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/22/12[/TD]
[TD="width: 64"]Activity3[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]Activity3[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/24/12[/TD]
[TD="width: 64"]Actvity1[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/24/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Nathan[/TD]
[TD="width: 64, align: right"]7/24/12[/TD]
[TD="width: 64"]Activity3[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]1x1[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/24/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/24/12[/TD]
[TD="width: 64"]Activity2[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/25/12[/TD]
[TD="width: 64"]Activity2[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/25/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/25/12[/TD]
[TD="width: 64"]Meeting[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/26/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Gina[/TD]
[TD="width: 64, align: right"]7/26/12[/TD]
[TD="width: 64"]Activity2[/TD]
[/TR]
[TR]
[TD="width: 64"]Morena[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]Activity3[/TD]
[/TR]
[TR]
[TD="width: 64"]Morena[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Morena[/TD]
[TD="width: 64, align: right"]7/23/12[/TD]
[TD="width: 64"]1x1[/TD]
[/TR]
[TR]
[TD="width: 64"]Morena[/TD]
[TD="width: 64, align: right"]7/24/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Morena[/TD]
[TD="width: 64, align: right"]7/25/12[/TD]
[TD="width: 64"]Lunch[/TD]
[/TR]
[TR]
[TD="width: 64"]Morena[/TD]
[TD="width: 64, align: right"]7/25/12[/TD]
[TD="width: 64"]Meeting[/TD]
[/TR]
</tbody>[/TABLE]


In seaching the forum if found this code

Option Explicit
Sub FillInAdjuster()
' hiker95, 08/05/2012
' http://www.mrexcel.com/forum/showthread.php?651583-Auto-fill-variable-cells-with-information-from-above
Dim r As Long, lr As Long
Application.ScreenUpdating = False
lr = Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
For r = 2 To lr Step 1
  If Cells(r, 1) = "" Then Cells(r, 1).Value = Cells(r - 1, 1).Value
Next r
Application.ScreenUpdating = True


End Sub

It results in:

[TABLE="class: grid, width: 415"]
<tbody>[TR]
[TD]Employee Name[/TD]
[TD]Activity Name[/TD]
[/TR]
[TR]
[TD]Nathan[/TD]
[TD]Manager: Ron[/TD]
[/TR]
[TR]
[TD="align: right"]7/22/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Actvity1[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Actvity1[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD]Activity3[/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7/22/2012[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]7/23/12[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Activity3[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Lunch[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Break[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7/23/2012[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Which is almost there except I need another column with the names and deleting rows.

Thank you for reading!

 

[texasalynn]

this is a little slow but works

Sub Name_Activity()
Dim LR As Long
LR = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
' clear cells with Manager and delete blank rows
    Cells.AutoFilter Field:=2, Criteria1:="=Manager*", Operator:=xlAnd
    Range("B2:B" & LR).ClearContents
    Cells.AutoFilter Field:=2, Criteria1:="="
    Cells.AutoFilter Field:=1, Criteria1:="="
    Range("A2:A" & LR).EntireRow.Delete
    Cells.AutoFilter
Range("A1").Select
LR = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Range("B:B").EntireColumn.Insert
For i = 2 To LR
        If Cells(i, 1) <> "" Then
            If WorksheetFunction.IsNumber(Cells(i, 1)) Then
            EmpDate = Cells(i, 1)
        Else
            EName = Cells(i, 1)
        End If
    End If
        Cells(i, 2) = EmpDate
        Cells(i, 1) = EName
Next i
' delete rows with no activity
    Cells.AutoFilter Field:=3, Criteria1:="="
    Range("A2:A" & LR).EntireRow.Delete
    Cells.AutoFilter
    Range("A1").ClearContents
Range("A1").Select
MsgBox "Done"
Application.ScreenUpdating = True
End Sub

someone else might have suggestions that will be faster

 

[mrhopko]

This should be a little faster as the work is done in memory

The macro asks you to select the report start and finish as i did not know how else to specify these

<CODE>
Sub ReformatTable()
Dim lrReportStart As Range
Dim lrReportEnd As Range
Dim lvaOldReport As Variant, lvaNewReport() As String
Dim lsName As String, lsDate As String, lsActivity As String
Dim i As Double, j As Double, k As Double, ldOldReportRows As Double
Dim ldNewReportRows As Double
Dim lrnewReportLocation As Range
'select report location, copy to an array and specify new report array size
Set lrReportStart = Application.InputBox("Select the top left cell of the report headers", "Report Start", , , , , , 8)
Set lrReportEnd = Application.InputBox("Select the bottom right cell of the report", "Report End", , , , , , 8)
lvaOldReport = Range(lrReportStart, lrReportEnd)
ldOldReportRows = UBound(lvaOldReport, 1)
'the new report should be the number of activity rows + header rows
j = 0
For i = 1 To ldOldReportRows
If (lvaOldReport(i, 2) <> Empty) And (Not lvaOldReport(i, 2) Like "Manager*") Then
j = j + 1
End If
Next i
ReDim lvaNewReport(1 To j, 3)
'set headers
lvaNewReport(1, 1) = "Name"
lvaNewReport(1, 2) = "Date"
lvaNewReport(1, 3) = "Activity"
'Re-Format Report
j = 2
For i = 2 To ldOldReportRows
If lvaOldReport(i, 2) Like "Manager*" Then
lsName = lvaOldReport(i, 1)
End If
If (lvaOldReport(i, 1) <> Empty) And (lvaOldReport(i, 2) = Empty) Then
lsDate = lvaOldReport(i, 1)
End If
If (lvaOldReport(i, 1) = Empty) And (lvaOldReport(i, 2) <> Empty) Then
lsActivity = lvaOldReport(i, 2)
lvaNewReport(j, 1) = lsName
lvaNewReport(j, 2) = lsDate
lvaNewReport(j, 3) = lsActivity
j = j + 1
End If
Next i
Set lrnewReportLocation = Application.InputBox("Select The Top left Cell for the new report Header Line", "Top of New Report", , , , , , 8)
Range(lrnewReportLocation, lrnewReportLocation.Offset(UBound(lvaNewReport, 1) - 1, 3)).Value = lvaNewReport
End Sub
</CODE>

I hope that Works

mrHopko

 

[GMLee]

this is a little slow but works

Sub Name_Activity()
Dim LR As Long
LR = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
' clear cells with Manager and delete blank rows
    Cells.AutoFilter Field:=2, Criteria1:="=Manager*", Operator:=xlAnd
    Range("B2:B" & LR).ClearContents
    Cells.AutoFilter Field:=2, Criteria1:="="
    Cells.AutoFilter Field:=1, Criteria1:="="
    Range("A2:A" & LR).EntireRow.Delete
    Cells.AutoFilter
Range("A1").Select
LR = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Range("B:B").EntireColumn.Insert
For i = 2 To LR
        If Cells(i, 1) <> "" Then
            If WorksheetFunction.IsNumber(Cells(i, 1)) Then
            EmpDate = Cells(i, 1)
        Else
            EName = Cells(i, 1)
        End If
    End If
        Cells(i, 2) = EmpDate
        Cells(i, 1) = EName
Next i
' delete rows with no activity
    Cells.AutoFilter Field:=3, Criteria1:="="
    Range("A2:A" & LR).EntireRow.Delete
    Cells.AutoFilter
    Range("A1").ClearContents
Range("A1").Select
MsgBox "Done"
Application.ScreenUpdating = True
End Sub

someone else might have suggestions that will be faster

This is working except it doesn't remove the rows that are Breaks and Phone along with the manager. I've tried to add them to the filter area but as there is three criteria I'm getting an error.

 

[GMLee]

This should be a little faster as the work is done in memory

The macro asks you to select the report start and finish as i did not know how else to specify these

<code>
Sub ReformatTable()
Dim lrReportStart As Range
Dim lrReportEnd As Range
Dim lvaOldReport As Variant, lvaNewReport() As String
Dim lsName As String, lsDate As String, lsActivity As String
Dim i As Double, j As Double, k As Double, ldOldReportRows As Double
Dim ldNewReportRows As Double
Dim lrnewReportLocation As Range
'select report location, copy to an array and specify new report array size
Set lrReportStart = Application.InputBox("Select the top left cell of the report headers", "Report Start", , , , , , 8)
Set lrReportEnd = Application.InputBox("Select the bottom right cell of the report", "Report End", , , , , , 8)
lvaOldReport = Range(lrReportStart, lrReportEnd)
ldOldReportRows = UBound(lvaOldReport, 1)
'the new report should be the number of activity rows + header rows
j = 0
For i = 1 To ldOldReportRows
If (lvaOldReport(i, 2) <> Empty) And (Not lvaOldReport(i, 2) Like "Manager*") Then
j = j + 1
End If
Next i
ReDim lvaNewReport(1 To j, 3)
'set headers
lvaNewReport(1, 1) = "Name"
lvaNewReport(1, 2) = "Date"
lvaNewReport(1, 3) = "Activity"
'Re-Format Report
j = 2
For i = 2 To ldOldReportRows
If lvaOldReport(i, 2) Like "Manager*" Then
lsName = lvaOldReport(i, 1)
End If
If (lvaOldReport(i, 1) <> Empty) And (lvaOldReport(i, 2) = Empty) Then
lsDate = lvaOldReport(i, 1)
End If
If (lvaOldReport(i, 1) = Empty) And (lvaOldReport(i, 2) <> Empty) Then
lsActivity = lvaOldReport(i, 2)
lvaNewReport(j, 1) = lsName
lvaNewReport(j, 2) = lsDate
lvaNewReport(j, 3) = lsActivity
j = j + 1
End If
Next i
Set lrnewReportLocation = Application.InputBox("Select The Top left Cell for the new report Header Line", "Top of New Report", , , , , , 8)
Range(lrnewReportLocation, lrnewReportLocation.Offset(UBound(lvaNewReport, 1) - 1, 3)).Value = lvaNewReport
End Sub
</code>

I hope that Works

mrHopko

Thank you! This is faster though I do have some additional columns that I still need in the report. I'm trying to break up the macro into steps so I can learn as I go, which is why I didn't include all the columns. I Have Start time and End times, Which I will be condensing into one column.