Separate data by month

Question

I have an employer list indicating the reinforcement shifts per dd/mm/yyyy in an Excel 2003 workbook.

With the next macro I get in the same document, all the GP per person multiplied by 4.83 indicating the result in a new column.

Option Explicit

Sub Resumen()
'------------------
'by Cacho Rodríguez
'------------------
Dim C As Range, Mat, Q&, i&, R&

On Error Resume Next
Set C = Application.InputBox("Selecciona la celda superior izquierda (CODIGO NÓMINA)" & vbLf & _
  "de tu rango de datos." & vbLf & vbLf & "(por ejemplo: Full1!$A$1)", Type:=8)
If C Is Nothing Then Exit Sub
On Error GoTo 0

Application.ScreenUpdating = False
With C.Worksheet
    Mat = .Range(C, .Cells(.Rows.Count, 1 + C.Column).End(xlUp).Offset(, 1))
End With
Q = UBound(Mat)
R = 1
Mat(R, 1) = Mat(1, 1)
Mat(R, 2) = Mat(1, 2)
Mat(R, 3) = "GP"

For i = 2 To Q
    Select Case True
    Case Mat(i, 1) = ""
        Mat(R, 3) = 1 + Mat(R, 3)

    Case IsNumeric(Mat(i, 1))
        R = 1 + R
        Mat(R, 1) = 0 + Mat(i, 1)
        Mat(R, 2) = Mat(i, 2)
        Mat(R, 3) = 0
   End Select
Next

C.Worksheet.[g1].CurrentRegion.Delete xlUp
With C.Worksheet.[g1].Resize(R, 3)
    Application.Goto .Cells(1).Offset(, -3), True
    .Value = Mat
    .Columns(4) = "=4.83 * " & .Cells(1, 3).Address(0, 0)
    .Cells(1, 4) = "Total"
    .Resize(, 4).Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

I need too all GF in a new column and in the "Total column", the result of GP+GF*4.83.

But I need the GP and GF separate per month, and the total per month per employer.

For example something like the next picture:

Answer 1

It took a bit for me to figure out what you want to do. If I understand properly: your 3rd image is a Summary of the data in the 1st image, and you want it to also include the data from your 2nd image.

If this is going to be an ongoing report then your first step should be organizing the data better, which will then make this and anything else you ever want to do with this data in Excel a lot easier for you and others.

If your data were organized like this:

...then with just a few clicks, you can have you data displayed like this automatically:

...and any time you add or change data, it take 1 click to update this table. It only took a few minutes to create this pivot table (now that the data is organized properly).

One in place, the pivot table can be changed with only a few clicks to instantly report on the data in different ways.

Same goes for Charts (which took a couple minutes to create, and will automatically update when the data changes) and various other Excel features:

You're doing things the "hard way" by using VBA to create your reports -- but it's very common from users who aren't aware of the functionality already built-in to Excel. But as I said, the first step in organizing your data in a more logical fashion (basically, "one record per row" with no sub-headings in between rows, like the Nom on your sample data.)

If you'd like to play around with the workbook I used for the examples, you can download it from Jumpshare here. (It probably won't display properly on the JumpShare website (because of the charts, etc) but click the Download button to download the [macro-free] .XLSX file.

---

More Information:

• Microsoft : Guidelines for organizing and formatting data on a worksheet

• Hubspot : How to Create a Pivot Table in Excel: A Step-by-Step Tutorial (With Video)

• Office.com : Create a PivotTable to analyze worksheet data

• GCFLearnFree: Introduction to Pivot Tables (with practice workbook)

Answer 2

Here is a macro that will reorder the data you have into a more useable format as recommended by @ashleedawg. The macro makes use of two Classes to help with orgainizing, and the self-documenting feature will be useful for future modifications.

After you have reordered your data, you can then apply pivot tables to generate whatever type of report you wish. For the 4,83 multiplier, you can add a Calculated Field to the Pivot Table.

And, you can even record a macro to automate the generation of the Pivot Table, if you wish.

For information on Classes, take a look at Chip Pearson's Introduction to Classes

As noted in the comments in the various modules:

• Be sure to set a Reference to Microsoft Scripting Runtime
• Be sure to rename the Class Modules
• Be sure your worksheets for the original and results data are named appropriately in the reOrder macro

Class Module

Option Explicit
'RENAME cShiftData

Private pCodigo As Long
Private pNom As String
Private pDt As Date
Private pDNI As String
Private pGP As Double
Private pGF As Double
Private pSD As cShiftData
Private pDts As Dictionary

Public Property Get Codigo() As Long
    Codigo = pCodigo
End Property
Public Property Let Codigo(Value As Long)
    pCodigo = Value
End Property

Public Property Get Nom() As String
    Nom = pNom
End Property
Public Property Let Nom(Value As String)
    pNom = Value
End Property

Public Property Get Dt() As Date
    Dt = pDt
End Property
Public Property Let Dt(Value As Date)
    pDt = Value
End Property

Public Property Get DNI() As String
    DNI = pDNI
End Property
Public Property Let DNI(Value As String)
    pDNI = Value
End Property

Public Property Get GP() As Double
    GP = pGP
End Property
Public Property Let GP(Value As Double)
    pGP = Value
End Property

Public Property Get GF() As Double
    GF = pGF
End Property
Public Property Let GF(Value As Double)
    pGF = Value
End Property

Public Property Get Dts() As Dictionary
    Set Dts = pDts
End Property
Public Function addDtsItem(dat As Date)
    If Dts.Exists(dat) Then
        MsgBox "Duplicate key will not be added"
    Else
        Dim V
        Set pSD = New cShiftData
        With pSD
            .GF = Me.GF
            .GP = Me.GP
        End With
        Dts.Add dat, pSD
    End If
End Function

Private Sub Class_Initialize()
    Set pDts = New Dictionary
End Sub

Class Module

Option Explicit
'RENAME cDateData

Private pGP As Double
Private pGF As Double

Public Property Get GP() As Double
    GP = pGP
End Property
Public Property Let GP(Value As Double)
    pGP = Value
End Property

Public Property Get GF() As Double
    GF = pGF
End Property
Public Property Let GF(Value As Double)
    pGF = Value
End Property

Regular Module

Option Explicit
'SET REFERENCE TO: Microsoft Scripting Runtime
Sub reOrder()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cSD As cShiftData, dSD As Dictionary
    Dim I As Long, J As Long
    Dim V As Variant, W As Variant

'set source and results worksheets
'read data into array

Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

Set wsSrc = Worksheets("Sheet1")
V = LastRowCol(wsSrc.Name)
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(V(0), V(1)))
End With

'collect the data
Set dSD = New Dictionary
For I = 1 To UBound(vSrc, 1)
    If Not vSrc(I, 1) Like "*CODIGO*" And _
        Len(vSrc(I, 1)) > 0 Then 'start of a new codigo
            Set cSD = New cShiftData
            With cSD
                .Codigo = vSrc(I, 1)
                .Nom = vSrc(I, 2)
                .DNI = vSrc(I, 3)
            dSD.Add Key:=.Codigo, Item:=cSD
            End With
    ElseIf Len(vSrc(I, 1)) = 0 Then
        With cSD
            .Dt = vSrc(I, 2)
            .GP = vSrc(I, 4)
            .GF = vSrc(I, 5)
            dSD(.Codigo).addDtsItem (.Dt)
        End With
    End If
Next I

'create results array
'one line for each date
I = 0
For Each V In dSD.Keys
    I = I + dSD(V).Dts.Count
Next V

ReDim vRes(0 To I, 1 To 6)

'Header row
vRes(0, 1) = "CODIGO NOMINA"
vRes(0, 2) = "NOM"
vRes(0, 3) = "D.N.I."
vRes(0, 4) = "FECHA"
vRes(0, 5) = "GP"
vRes(0, 6) = "GF"

I = 0
For Each V In dSD.Keys
    With dSD(V)
        For Each W In .Dts
            I = I + 1
            vRes(I, 1) = .Codigo
            vRes(I, 2) = .Nom
            vRes(I, 3) = .DNI
            vRes(I, 4) = W
            vRes(I, 5) = .Dts(W).GP
            vRes(I, 6) = .Dts(W).GF
        Next W
    End With
Next V

'write the results
Application.ScreenUpdating = False
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Columns(4).NumberFormat = "dd/mm/yyyy"
    .Columns(1).HorizontalAlignment = xlCenter
    With .EntireColumn
        .ColumnWidth = 255
        .AutoFit
    End With
End With

myPivot wsRes

Application.ScreenUpdating = True

End Sub

Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

Original Data

reOrdered Data (after running macro)

Example Pivot Table