Separate data by month - excel

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