Macro to generate summary based on Dates

[Silver]

Hope you people can help me out here.

There are 2 sheets Simon and Summary

In Sheet Simon, Column A has Dates, this column also determines the rows where the daily production data is entered.

Row 3 has categories (uses 3 merged cells)
Row 4 has 3 sub-categories namely Time, Counts and Production

Macro should prompt the user to enter date and when clicked on button say Retrieve, should retrieve the data.

Brief description -

I have prepared a summary sheet with headings as Date, Category, Time, Counts and Production

Dates are maintained in 1,2,3 format in the sheet Simon.

When I enter date as 1 macro should search through the relevant row. When it comes across a data it should first paste the Date in Column A, categories in column B, followed by datas under the sub-categories in Column C, D and E of the summary sheet .

Note :

1) Sub-category Production has formula. Hope macro can paste it as values.
2) Since the macro will be run on a daily basis, it should paste the datas in the next blank cell in the summary sheet

Sample sheet attached

[mperrah]

try this
You can add a command button that says "Add to Summary"
then choose this macro.


Sub vbax52635()
Dim nr, c, i, s, uDate As Long
Dim wsn, wsy As Worksheet
Dim wb As Workbook

Set wb = ActiveWorkbook
Set wsn = wb.Worksheets("Simon")
Set wsy = wb.Worksheets("Summary")

nr = wsy.Cells(Rows.Count, 2).End(xlUp).Row + 1
On Error Resume Next
uDate = InputBox("What date do you wish to add to Summary?")

If uDate = False Then
MsgBox ("You didn't enter a date")
End If

For c = 5 To 35
If wsn.Cells(c, 1).Value = uDate Then
wsy.Cells(nr, 1).Value = uDate
For i = 7 To 22 Step 3
wsy.Cells(nr, 2).Value = wsn.Cells(3, i).Value
For s = 0 To 2
wsy.Cells(nr, s + 3).Value = wsn.Cells(c, i + s).Value
Next s
nr = nr + 1
Next i
End If
Next c
End Sub

[Silver]

Above code generates only half summary.

There are Categories which only has 1 Sub-Category namely Time. The code does not generate summary for this particular sub-category. In the attached sheet it will be columns Z, AA, AB and AC. (Columns will change as new categories get added)

Note :

Since new categories are going to be added, the code should be able to pick-up the new categories also.

[mperrah]

did not get that from the original post

Please include more then 1 line in sample data
Please fill out the Summary sheet as you want it after code runs,
a blank sheet leaves a lot to the imagination...

[Silver]

Have attached sheet, for explanation refer summary sheet.

[mperrah]

This revision only adds to summary categories with values
added time values using category names - only ones with values
as far as adding categories later, the range count can be added to the loop count to include more columns

Sub vbax52635()
Dim nr, c, i, s, t, uDate As Long
Dim wsn, wsy As Worksheet
Dim wb As Workbook

Set wb = ActiveWorkbook
Set wsn = wb.Worksheets("Simon")
Set wsy = wb.Worksheets("Summary")

nr = wsy.Cells(Rows.Count, 2).End(xlUp).Row + 1
On Error Resume Next
uDate = InputBox("What date do you wish to add to Summary?")

If uDate = False Then
MsgBox (" You didn't enter a date")
End If

For c = 5 To 35 ' this is the date range - increase 35 to what ever last row is as needed
If wsn.Cells(c, 1).Value = uDate Then
wsy.Cells(nr, 1).Value = uDate
For i = 7 To 22 Step 3 ' this is the first level category list skipping over each 3 cell group - increase as needed
If wsn.Cells(c, i).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, i).Value
For s = 0 To 2 ' this is for the sub category level which is part of summary sheet - increase as needed (0 to 2 counts 3 cells)
wsy.Cells(nr, s + 3).Value = wsn.Cells(c, i + s).Value
Next s
nr = nr + 1
End If
Next i

For t = 26 To 29 ' this is for the Time categories - increase as needed
If wsn.Cells(c, t).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, t).Value
wsy.Cells(nr, 3).Value = wsn.Cells(c, t).Value
nr = nr + 1
End If
Next t
End If
Next c
End Sub

[mperrah]

just noticed you altered the "Simon" sheet on your second attachment,
and removed the blank column Y
my code was working off the data with the blank row.
My code can be revised if you plan on using the data without the blank column...
the time group started on Column Z using this code:

For t = 26 To 29 ' this is for the Time categories - increase as needed
change to:

For t = 25 To 28 ' this is for the Time categories - increase as needed
if the time group will start on column Y

[Silver]

THIS IS JUST EXCELLENT.

There was a last minute change to the Date Column in the Sheet Simon.

Note : Sheet Simon has a Userform

The dates were maintained in number format - 1, 2, 3

Now the request is to maintain the dates in below format

01-May-015

Just made 1 change to the date column to see if the userform can perform the function.

I get a pop-up message stating 5/1/2015 not found when I click the Enter button on the userform.

Below is part of the code :



Private Sub cmdAdd_Click()
Dim iRow As Long, iCol As Long, res As Variant
Dim r As Range, r1 As Range, r2 As Range


If Me.cmbDate = "" Then
MsgBox "please select a date"
cmbDate.SetFocus
Exit Sub
End If
With ActiveSheet
Set r = .Columns(1).Cells
res = Application.Match(CLng(CDate(Me.cmbDate.Value)), r, 0)
If Not IsError(res) Then
Set r1 = r(res)
iRow = r1.Row
Else
MsgBox Me.cmbDate.Value & " was not found"
Exit Sub
End If
End With
If Me.cmbCat = "" Then
MsgBox "please select a category"
cmbCat.SetFocus
Exit Sub
End If
With ActiveSheet
iCol = .Range("3:3").Find(Me.cmbCat.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
End With


If TextBoxTime = "" Then
MsgBox "please enter Time"
TextBoxTime.SetFocus
Exit Sub
End If
With ActiveSheet
Set r2 = .Cells(3, iCol).Offset(0, 1)
If r2.MergeArea.Address <> r2.Address Then
If Me.TextBoxCounts = "" Then
MsgBox "please enter Counts"
Me.TextBoxCounts.SetFocus
Exit Sub
End If
End If
End With
With ActiveSheet


What part of the code should be changed so that the userform can pick the correct date.

Note : Previously attached sheet contains the above code and the userform.

[mperrah]

Not sure how you get the date formatting to 01-may-015
mine reverts to 2015 (I tried format dd-mmm-yyy)
if dd-mm-yyyy is ok, I'll try to see whats happening

[Silver]

Oops... My mistake.

The date format is 01-May-15

Above format is what will be preferred.

If not then 01-May-2015 will be OK

[mperrah]

In this code I commented out an if statement that seems to get it to work
not sure what you are doing with the mergearea.
I'm not getting any errors now

this is in the cmdAdd_click section

With ActiveSheet
.Cells(iRow, iCol) = Me.TextBoxTime.Value
'If r2.MergeArea.Address <> r2.Address Then
If Len(Trim(Me.TextBoxCounts.Value)) > 0 Then
.Cells(iRow, iCol + 1) = Me.TextBoxCounts.Value
End If
'End If

End With

[mperrah]

I did notice that on my code I used: Dim uDate as long
I changed this to Dim uDate as Date

[mperrah]

You can use this to have the user select a cell with the date wanted for adding to summary
it checks that the active cell is in column(1) then procedes

Sub vbax52635()
Dim nr, c, i, s, t As Long
Dim wsn, wsy As Worksheet
Dim wb As Workbook
Dim uDate As Date

Set wb = ActiveWorkbook
Set wsn = wb.Worksheets("Simon")
Set wsy = wb.Worksheets("Summary")

nr = wsy.Cells(Rows.Count, 2).End(xlUp).Row + 1
On Error Resume Next

If ActiveCell.Column = Columns(1) Then
uDate = ActiveCell
If uDate = False Then
MsgBox ("Please Select a date to add to summary")
End If
End If

For c = 5 To 35
If wsn.Cells(c, 1).Value = uDate Then
wsy.Cells(nr, 1).Value = uDate
For i = 7 To 22 Step 3
If wsn.Cells(c, i).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, i).Value
For s = 0 To 2
wsy.Cells(nr, s + 3).Value = wsn.Cells(c, i + s).Value
Next s
nr = nr + 1
End If
Next i

For t = 26 To 29
If wsn.Cells(c, t).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, t).Value
wsy.Cells(nr, 3).Value = wsn.Cells(c, t).Value
nr = nr + 1
End If
Next t
End If
Next c
End Sub

[Silver]

I must be doing something wrong.

I pasted the date code suggested by you, still getting the same pop-up

Below is code, last part is where I copy pasted your code.



Private Sub cmdAdd_Click()
Dim iRow As Long, iCol As Long, res As Variant
Dim r As Range, r1 As Range, r2 As Range


If Me.cmbDate = "" Then
MsgBox "please select a date"
cmbDate.SetFocus
Exit Sub
End If
With ActiveSheet
Set r = .Columns(1).Cells
res = Application.Match(CLng(CDate(Me.cmbDate.Value)), r, 0)
If Not IsError(res) Then
Set r1 = r(res)
iRow = r1.Row
Else
MsgBox Me.cmbDate.Value & " was not found"
Exit Sub
End If
End With
If Me.cmbCat = "" Then
MsgBox "please select a category"
cmbCat.SetFocus
Exit Sub
End If
With ActiveSheet
iCol = .Range("3:3").Find(Me.cmbCat.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
End With


If TextBoxTime = "" Then
MsgBox "please enter Time"
TextBoxTime.SetFocus
Exit Sub
End If
With ActiveSheet
Set r2 = .Cells(3, iCol).Offset(0, 1)
If r2.MergeArea.Address <> r2.Address Then
If Me.TextBoxCounts = "" Then
MsgBox "please enter Counts"
Me.TextBoxCounts.SetFocus
Exit Sub
End If
End If
End With
With ActiveSheet

' copy pasted the date code

.Cells(iRow, iCol) = Me.TextBoxTime.Value
'If r2.MergeArea.Address <> r2.Address Then
If Len(Trim(Me.TextBoxCounts.Value)) > 0 Then
.Cells(iRow, iCol + 1) = Me.TextBoxCounts.Value
End If
'End If

End With


If you can attach the working code it will be GREAT.

Kindly HELP me out here...

[mperrah]

13474
this is what I have

[Silver]

I think there is some confusion.

Summary button and code is working fine.

Below is the pop-up I'm getting when clicked on Enter on the userform.

13478

[mperrah]

Not sure where your problem is? I added the same values as your screen shot and it fills in the space as it should.
Are you using the file I just posted?
Can you confirm the Dim at the top for uDate is Date instead of Long

[mperrah]

13480

[Silver]

I would like you to do a small task as below in the sheet that you have provided me.

Scenario 1 -

1) In cell A5 insert numerical value 1
2) Click on the RED button and select 1 from the Date box
3) Select Refunds from the Category box
4) Insert Time as 00:00 and Counts as 5 and click on Enter

Scenario 2 -

1) In cell A5 insert date as 1-May-15
2) Select 5/1/2015 in the date box and follow the remaining steps as mentioned above

Getting the pop-up message for Scenario 2

[mperrah]

On my sheet I used CTRL+1 and format cells (A:A) as date dd-mm-yy
If I enter 1 it puts 1-jan-00
And your user form loads the first date in the drop down (shows 12/31/1899 ?)
but it loads the entered values to row 5 without error...
you might want to review how your user form loads the date value from Column A after you changed the format from 1 to 1-may-15
it was long before, now its a date, so excel handles those differently

[Silver]

That is where I'm stuck. Can you HELP me out.

[mperrah]

I re-downloaded the last file I posted and I get no errors?
I have been looking through your userform and I cant see anything that looks off.
It must be something in the cDate area.
You have
res = Application.Match(CLng(CDate(Me.cmbDate.Value)), r, 0)
the CLng part is converting the match to a long format, you want date format now that you have changed the values in first column
I tried removing CLng but not sure what else to do, this causes the error you have. leaving it on my there is no error - strange?

[Silver]

Well then lets call it a day. You have given it ALL YOU HAVE.

I cant THANK YOU ENOUGH.

Still... YOU have got a LOT OF PATIENCE :bow: :clap: :bow:

From the BOTTOM OF MY HEART... THANK YOU for your Time, Effort and Patience to REPLY to all my query... GOD BLESS YOU

[mperrah]

13482
I cleaned a few things up.
This does not generate errors for me.

to add to summary be sure you have a cell in column A5:A35 selected first

[mperrah]

Glad to help, it was a unique challenge.
Here is all the code I could find in your workbook,
Maybe Yongle or someone else can see something I'm missing..


Private Sub cmdAdd_Click()
Dim iRow, iCol As Long
Dim r, r1, r2 As Range
Dim res

If Me.cmbDate = "" Then
MsgBox "please select a date"
cmbDate.SetFocus
Exit Sub
End If
With ActiveSheet
Set r = .Columns(1).Cells
res = Application.Match(CLng(CDate(Me.cmbDate.Value)), r, 0)
If Not IsError(res) Then
Set r1 = r(res)
iRow = r1.Row
Else
MsgBox Me.cmbDate.Value & " was not found"
Exit Sub
End If
End With
If Me.cmbCat = "" Then
MsgBox "please select a category"
cmbCat.SetFocus
Exit Sub
End If
With ActiveSheet
iCol = .Range("3:3").Find(Me.cmbCat.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
End With

If TextBoxTime = "" Then
MsgBox "please enter Time"
TextBoxTime.SetFocus
Exit Sub
End If
With ActiveSheet
Set r2 = .Cells(3, iCol).Offset(0, 1)
If r2.MergeArea.Address <> r2.Address Then
If Me.TextBoxCounts = "" Then
MsgBox "please enter Counts"
Me.TextBoxCounts.SetFocus
Exit Sub
End If
End If
End With

With ActiveSheet
.Cells(iRow, iCol) = Me.TextBoxTime.Value
'If r2.MergeArea.Address <> r2.Address Then
If Len(Trim(Me.TextBoxCounts.Value)) > 0 Then
.Cells(iRow, iCol + 1) = Me.TextBoxCounts.Value
End If
'End If

End With

'clear the data
Me.cmbDate.Value = ""
Me.cmbCat.Value = ""
Me.TextBoxTime.Value = ""
Me.TextBoxCounts.Value = ""
Me.cmbDate.SetFocus

End Sub

Private Sub cmdDone_Click()
Unload Me
End Sub

Private Sub cmdGoto_Click()
If Me.cmbCat = "" Then
MsgBox "please select a category"
cmbCat.SetFocus
Exit Sub
End If
With ActiveSheet
iCol = .Range("3:3").Find(Me.cmbCat.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
Application.Goto .Cells(3, iCol), Scroll:=True
End With

End Sub

Private Sub UserForm_Initialize()
Dim cItem As Range
Dim ws As Worksheet

Set ws = ActiveSheet
For Each cItem In ws.Range("G3:AC3").SpecialCells(xlConstants).Offset(, 0)
With Me.cmbCat
If cItem <> "" And cItem <> "Total" Then .AddItem cItem.Value
End With
Next cItem

For Each cItem In ws.Range("A5:A35").SpecialCells(xlConstants)
With Me.cmbDate
.AddItem Format(cItem, "d-mmm-yy")
End With
Next cItem
Me.cmbDate.SetFocus
End Sub

Sub abc()
Dim r As Range, dt As Date

Set r = Worksheets("Simon").Range("A5:A35")
dt = CDate("5/1/2015")
res = Application.Match(dt, r, 0)
Debug.Print r(res).Address
End Sub
Sub Rectangle1_Click()
fmExpenditure.Show False
End Sub
Sub vbax52635()
Dim nr, c, i, s, t As Long
Dim wsn, wsy As Worksheet
Dim wb As Workbook
Dim uDate As Date

Set wb = ActiveWorkbook
Set wsn = wb.Worksheets("Simon")
Set wsy = wb.Worksheets("Summary")

nr = wsy.Cells(Rows.Count, 2).End(xlUp).Row + 1
On Error Resume Next

If ActiveCell.Column = Columns(1) Then
uDate = ActiveCell
If uDate = False Then
MsgBox ("Please Select a date to add to summary")
End If
End If

For c = 5 To 35
If wsn.Cells(c, 1).Value = uDate Then
wsy.Cells(nr, 1).Value = uDate
For i = 7 To 22 Step 3
If wsn.Cells(c, i).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, i).Value
For s = 0 To 2
wsy.Cells(nr, s + 3).Value = wsn.Cells(c, i + s).Value
Next s
nr = nr + 1
End If
Next i

For t = 26 To 29
If wsn.Cells(c, t).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, t).Value
wsy.Cells(nr, 3).Value = wsn.Cells(c, t).Value
nr = nr + 1
End If
Next t
End If
Next c
End Sub

[Silver]

The file from your last attachment SAVED ME.

User form picks the date in correct format. Don't know what you did but its working.

Just need one more assistance with the column Date in summary.

Below is how the current code generates summary

13487

Below is how the summary should look, which will be VERY HELPFUL for pivot table.

13488

[Silver]

mperrah... your ASSISTANCE will be HELPFUL

Anyone out there who can HELP me with this...

[mperrah]

Glad to help, it was a unique challenge.
Here is all the code I could find in your workbook,
Maybe Yongle or someone else can see something I'm missing..


Private Sub cmdAdd_Click()
Dim iRow, iCol As Long
Dim r, r1, r2 As Range
Dim res

If Me.cmbDate = "" Then
MsgBox "please select a date"
cmbDate.SetFocus
Exit Sub
End If
With ActiveSheet
Set r = .Columns(1).Cells
res = Application.Match(CLng(CDate(Me.cmbDate.Value)), r, 0)
If Not IsError(res) Then
Set r1 = r(res)
iRow = r1.Row
Else
MsgBox Me.cmbDate.Value & " was not found"
Exit Sub
End If
End With
If Me.cmbCat = "" Then
MsgBox "please select a category"
cmbCat.SetFocus
Exit Sub
End If
With ActiveSheet
iCol = .Range("3:3").Find(Me.cmbCat.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
End With

If TextBoxTime = "" Then
MsgBox "please enter Time"
TextBoxTime.SetFocus
Exit Sub
End If
With ActiveSheet
Set r2 = .Cells(3, iCol).Offset(0, 1)
If r2.MergeArea.Address <> r2.Address Then
If Me.TextBoxCounts = "" Then
MsgBox "please enter Counts"
Me.TextBoxCounts.SetFocus
Exit Sub
End If
End If
End With

With ActiveSheet
.Cells(iRow, iCol) = Me.TextBoxTime.Value
'If r2.MergeArea.Address <> r2.Address Then
If Len(Trim(Me.TextBoxCounts.Value)) > 0 Then
.Cells(iRow, iCol + 1) = Me.TextBoxCounts.Value
End If
'End If

End With

'clear the data
Me.cmbDate.Value = ""
Me.cmbCat.Value = ""
Me.TextBoxTime.Value = ""
Me.TextBoxCounts.Value = ""
Me.cmbDate.SetFocus

End Sub

Private Sub cmdDone_Click()
Unload Me
End Sub

Private Sub cmdGoto_Click()
If Me.cmbCat = "" Then
MsgBox "please select a category"
cmbCat.SetFocus
Exit Sub
End If
With ActiveSheet
iCol = .Range("3:3").Find(Me.cmbCat.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
Application.Goto .Cells(3, iCol), Scroll:=True
End With

End Sub

Private Sub UserForm_Initialize()
Dim cItem As Range
Dim ws As Worksheet

Set ws = ActiveSheet
For Each cItem In ws.Range("G3:AC3").SpecialCells(xlConstants).Offset(, 0)
With Me.cmbCat
If cItem <> "" And cItem <> "Total" Then .AddItem cItem.Value
End With
Next cItem

For Each cItem In ws.Range("A5:A35").SpecialCells(xlConstants)
With Me.cmbDate
.AddItem Format(cItem, "d-mmm-yy")
End With
Next cItem
Me.cmbDate.SetFocus
End Sub

Sub abc()
Dim r As Range, dt As Date

Set r = Worksheets("Simon").Range("A5:A35")
dt = CDate("5/1/2015")
res = Application.Match(dt, r, 0)
Debug.Print r(res).Address
End Sub
Sub Rectangle1_Click()
fmExpenditure.Show False
End Sub
Sub vbax52635()
Dim nr, c, i, s, t As Long
Dim wsn, wsy As Worksheet
Dim wb As Workbook
Dim uDate As Date

Set wb = ActiveWorkbook
Set wsn = wb.Worksheets("Simon")
Set wsy = wb.Worksheets("Summary")

nr = wsy.Cells(Rows.Count, 2).End(xlUp).Row + 1
On Error Resume Next

If ActiveCell.Column = Columns(1) Then
uDate = ActiveCell
If uDate = False Then
MsgBox ("Please Select a date to add to summary")
End If
End If

For c = 5 To 35
If wsn.Cells(c, 1).Value = uDate Then

For i = 7 To 22 Step 3
If wsn.Cells(c, i).Value <> "" Then
wsy.Cells(nr, 1).Value = uDate
wsy.Cells(nr, 2).Value = wsn.Cells(3, i).Value
For s = 0 To 2
wsy.Cells(nr, s + 3).Value = wsn.Cells(c, i + s).Value
Next s
nr = nr + 1
End If
Next i

For t = 26 To 29
If wsn.Cells(c, t).Value <> "" Then
wsy.Cells(nr, 2).Value = wsn.Cells(3, t).Value
wsy.Cells(nr, 3).Value = wsn.Cells(c, t).Value
nr = nr + 1
End If
Next t
End If
Next c
End Sub



Try this. Not at my of today so can't test

[mperrah]

This fulfills your latest request

Sub vbax52635()
Dim nr, c, i, s, t As Long
Dim wsn, wsy As Worksheet
Dim wb As Workbook
Dim uDate As Date

Set wb = ActiveWorkbook
Set wsn = wb.Worksheets("Simon")
Set wsy = wb.Worksheets("Summary")

nr = wsy.Cells(Rows.Count, 2).End(xlUp).Row + 1
On Error Resume Next

If ActiveCell.Column = Columns(1) Then
uDate = ActiveCell
If uDate = False Then
MsgBox ("Please Select a date to add to summary")
End If
End If

For c = 5 To 35
If wsn.Cells(c, 1).Value = uDate Then

For i = 7 To 22 Step 3
If wsn.Cells(c, i).Value <> "" Then
wsy.Cells(nr, 1).Value = uDate
wsy.Cells(nr, 2).Value = wsn.Cells(3, i).Value
For s = 0 To 2
wsy.Cells(nr, s + 3).Value = wsn.Cells(c, i + s).Value
Next s
nr = nr + 1
End If
Next i

For t = 26 To 29
If wsn.Cells(c, t).Value <> "" Then
wsy.Cells(nr, 1).Value = uDate
wsy.Cells(nr, 2).Value = wsn.Cells(3, t).Value
wsy.Cells(nr, 3).Value = wsn.Cells(c, t).Value
nr = nr + 1
End If
Next t
End If
Next c
End Sub

[Silver]

Once again THANKS... mperrah

[mperrah]

glad we found a solution

[Silver]

I have posted a new topic... your expertise will be APPRECIATED