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:

Employee Name	Activity Name
Nathan	Manager: Ron
7/22/12
	Phone
	Break
	Phone
	Lunch
	Actvity1
	Break
	Actvity1
	Break
	Activity3
7/23/12
	Phone
	Break
	Activity3
	Lunch
	Phone
	Break
	Phone
	Break
	Phone
7/24/12
	Actvity1
	Break
	Phone
	Lunch
	Activity3
	Break
	Phone
	Break
	Phone
Gina	Manager: Jewel
7/23/12
	Phone
	Phone
	Break
	Phone
	Lunch
	Phone
	1x1
	Phone
	Break
	Phone
7/24/12
	Phone
	Break
	Phone
	Lunch
	Activity2
	Break
	Phone
7/25/12
	Phone
	Activity2
	Break
	Phone
	Lunch
	Phone
	Meeting
	Break
	Phone
7/26/12
	Phone
	Phone
	Break
	Phone
	Lunch
	Activity2
	Break
	Phone
Morena	Manager: Sean
7/23/12
	Phone
	Activity3
	Break
	Phone
	Lunch
	Phone
	1x1
	Phone
	Break
	Phone
7/24/12
	Phone
	Break
	Phone
	Lunch
	Phone
	Break
	Phone
7/25/12
	Phone
	Phone
	Break
	Phone
	Lunch
	Phone
	Meeting
	Break
	Phone

<tbody>
</tbody>

To looking like this:
Rows that are blank, or contain Phone and or Break are being deleted

		Activity Name
Nathan	7/22/12	Lunch
Nathan	7/22/12	Actvity1
Nathan	7/22/12	Actvity1
Nathan	7/22/12	Activity3
Nathan	7/23/12	Activity3
Nathan	7/23/12	Lunch
Nathan	7/24/12	Actvity1
Nathan	7/24/12	Lunch
Nathan	7/24/12	Activity3
Gina	7/23/12	Lunch
Gina	7/23/12	1x1
Gina	7/24/12	Lunch
Gina	7/24/12	Activity2
Gina	7/25/12	Activity2
Gina	7/25/12	Lunch
Gina	7/25/12	Meeting
Gina	7/26/12	Lunch
Gina	7/26/12	Activity2
Morena	7/23/12	Activity3
Morena	7/23/12	Lunch
Morena	7/23/12	1x1
Morena	7/24/12	Lunch
Morena	7/25/12	Lunch
Morena	7/25/12	Meeting

<tbody>
</tbody>

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:

Employee Name	Activity Name
Nathan	Manager: Ron
7/22/12
7/22/2012	Phone
7/22/2012	Break
7/22/2012	Phone
7/22/2012	Lunch
7/22/2012	Actvity1
7/22/2012	Break
7/22/2012	Actvity1
7/22/2012	Break
7/22/2012	Activity3
7/22/2012
7/22/2012
7/23/12
7/23/2012	Phone
7/23/2012	Break
7/23/2012	Activity3
7/23/2012	Lunch
7/23/2012	Phone
7/23/2012	Break
7/23/2012	Phone
7/23/2012	Break
7/23/2012	Phone
7/23/2012
7/23/2012

<tbody>
</tbody>

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.