Solved

Help w/ Excel Macro

Posted on 2013-05-13
9
229 Views
Last Modified: 2014-05-23
Sample data is located on the "From This" worksheet.  I want a macro that I run that creates a new sheet and does the following:

What I need created is similar to what a pivot table can do but I need a macro to perform this function.

The unique columns are going to be the emp# and projNo where I need to sum all the "Actual Hours Worked" for each projNo and emp#.

The edge case is then the projNo is 111-001 for a person.  111-001 projNo have five different places to put hours, Columns G - K.  Those need to be summed and put in their respective columns.

"Do This" worksheet is the sample output.
example.xlsx
0
Comment
Question by:michaelblitz
  • 3
  • 2
  • 2
9 Comments
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
Comment Utility
Why is project5 repeated on the do this worksheet?
0
 
LVL 80

Expert Comment

by:byundt
Comment Utility
Sure looks to me like a PivotTable would do what you want. Would you like a macro that creates the PivotTable?
0
 

Author Comment

by:michaelblitz
Comment Utility
Project 5 is repeated because the hours are in different columns.

Yes it does look like a PivotTable but I cannot use the PivotTable feature in this instance.
0
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 
LVL 43

Expert Comment

by:Saqib Husain, Syed
Comment Utility
Can you not have all the project 5 on one line and different columns instead of separate lines? This way programming would be easier as well as deterministic and, I believe, would be more presentable.
0
 

Author Comment

by:michaelblitz
Comment Utility
No I cannot.  Project Code 111-001 is the only possible project that will have this scenario so you could just base it off that.

Also, project codes are unique, project names are not.
0
 
LVL 80

Accepted Solution

by:
byundt earned 500 total points
Comment Utility
I decided to make a temporary PivotTable, then copy the values over to a new worksheet to produce the desired report. The order of rows for Project 111-001 is in the order of the hours reported in the various columns--only one type of hours are reported per row, but the rows are in a different order than you showed in your desired output.
Sub Reporter()
Application.ScreenUpdating = False
TableIt
MakePT
MakeReport
End Sub

Private Sub TableIt()
Dim lst As ListObject
With ActiveSheet
    If .ListObjects.Count = 0 Then
        Set lst = .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Range("A3").CurrentRegion, xllistobjecthasheaders:=xlYes)
        lst.Name = "tbData"
    End If
End With
End Sub

Private Sub MakePT()
Sheets.Add After:=ActiveSheet
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="tbData").CreatePivotTable _
    TableDestination:=ActiveSheet.Name & "!R3C1", TableName:="PivotTable1"
With ActiveSheet.PivotTables("PivotTable1")
    With .PivotFields("projNo")
        .Orientation = xlRowField
        .Position = 1
    End With
    With .PivotFields("emp#")
        .Orientation = xlRowField
        .Position = 2
    End With
    With .PivotFields("Project Name")
        .Orientation = xlRowField
        .Position = 3
    End With
    With .PivotFields("Employee Name")
        .Orientation = xlRowField
        .Position = 4
    End With
    With .PivotFields("Rate")
        .Orientation = xlRowField
        .Position = 5
    End With
    .AddDataField .PivotFields("Actual Hours Worked"), "Sum of Actual Hours Worked", xlSum
    .AddDataField .PivotFields("Vac"), "Sum of Vac", xlSum
    .AddDataField .PivotFields("Sick"), "Sum of Sick", xlSum
    .AddDataField .PivotFields("Hol"), "Sum of Hol", xlSum
    .AddDataField .PivotFields("Personal Day"), "Sum of Personal Day", xlSum
    
    .ColumnGrand = False
    .RowGrand = False
    With .PivotFields("projNo")
        .LayoutForm = xlTabular
        .RepeatLabels = True
        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    With .PivotFields("emp#")
        .LayoutForm = xlTabular
        .RepeatLabels = True
        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    With .PivotFields("Project Name")
        .LayoutForm = xlTabular
        .RepeatLabels = True
        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    With .PivotFields("Employee Name")
        .LayoutForm = xlTabular
        .RepeatLabels = True
        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
    End With
End With
End Sub

Private Sub MakeReport()
Dim pt As PivotTable
Dim cel As Range, rg As Range
Dim i As Long, j As Long, k As Long, n As Long, nVals As Long
Set pt = ActiveSheet.PivotTables(1)
Sheets.Add After:=ActiveSheet
With ActiveSheet
    pt.TableRange1.Copy
    .Range("A1").PasteSpecial Paste:=xlPasteValues
    .Rows(1).Delete
    Application.DisplayAlerts = False
    pt.TableRange1.Worksheet.Delete
    Application.DisplayAlerts = True
    .Range("A1:B1").EntireColumn.Insert
    .Range("E:F").Cut .Range("A:B")
    .Range("E:F").Delete
    .Range("A1:J1").Value = _
        Array("Project Name", "Employee Name", "Proj Number", "emp#", "Rate", "Actual Hours Worked", "Vac", "Sick", "Hol", "Personal Day")
    .Range("A1:J1").Columns.AutoFit
    .Columns(1).ColumnWidth = 15.86
    .Columns(4).ColumnWidth = 14.43
    Set rg = .Cells(2, "A")
    Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp))
    rg.EntireRow.Sort rg.Cells(1, 1), xlAscending
    n = rg.Rows.Count
    For i = n To 1 Step -1
        nVals = Application.CountIf(rg.Cells(i, 6).Resize(1, 5), ">0")
        If nVals > 1 Then
            rg.Cells(i + 1, 1).EntireRow.Resize(nVals).Insert
            rg.Cells(i + 1, 1).Resize(nVals, 5).Value = rg.Cells(i, 1).Resize(1, 5).Value
            rg.Cells(i + 1, 6).Resize(nVals, 5).Value = Array(0, 0, 0, 0, 0)
            k = 0
            For j = 1 To 5
                If rg.Cells(i, 5 + j).Value <> 0 Then
                    k = k + 1
                    rg.Cells(i + k, 5 + j).Value = rg.Cells(i, 5 + j).Value
                End If
            Next
            rg.Cells(i, 1).EntireRow.Delete
        End If
    Next
    .Cells(1, 1).Select
End With
End Sub

Open in new window

Brad
0
 

Author Comment

by:michaelblitz
Comment Utility
Thanks Brad.  Let me take a look
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

This very simple solution applies to a narrow cross-section of the "needs to close" variety. In this case, the full message in Event Viewer was in applog, Event ID 1000: Faulting application iexplore.exe, version 8.0.6001.18702, faulting module …
Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

7 Experts available now in Live!

Get 1:1 Help Now