Solved

Help w/ Excel Macro

Posted on 2013-05-13
9
237 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
ID: 39163395
Why is project5 repeated on the do this worksheet?
0
 
LVL 81

Expert Comment

by:byundt
ID: 39163413
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
ID: 39165695
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
Ransomware-A Revenue Bonanza for Service Providers

Ransomware – malware that gets on your customers’ computers, encrypts their data, and extorts a hefty ransom for the decryption keys – is a surging new threat.  The purpose of this eBook is to educate the reader about ransomware attacks.

 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 39165865
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
ID: 39165888
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 81

Accepted Solution

by:
byundt earned 500 total points
ID: 39167032
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
ID: 39205568
Thanks Brad.  Let me take a look
0

Featured Post

Ransomware-A Revenue Bonanza for Service Providers

Ransomware – malware that gets on your customers’ computers, encrypts their data, and extorts a hefty ransom for the decryption keys – is a surging new threat.  The purpose of this eBook is to educate the reader about ransomware attacks.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

932 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