report generation

HanSam · Nov 14, 2016

Hi,

I need help on writing the code for this problem.

Please see attached file.

What I want to happen:

Cell D2 is a dropdown list that user can change according to the week a report is to be generated.
When you click the "Generate Reports" button, two files will be generated. What I want is to pass the data from Data Entry sheet to the reports generated according to these rules.

For the file that says OK for Approval, these should be the filters

Week (Based on the chosen week number on the dropdown list)
Date when processed (Should be "by CTL")

For the file that says Reject, these should be the filters

Week (Based on the chosen week number on the dropdown list)
Status (Reject)

Hope to get help from you guys. Thanks!

PCosta87 · Nov 14, 2016

Hi @HanSam

Please try the following... the CCDB module should read:

Code:

Option Explicit
Public prjDict As Object

Sub Button3_Click()

frmCCDB.Show vbModeless

On Error Resume Next

End Sub

Public Function prjNumCheck(eStr As String) As Boolean

Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")

With regex
    .Pattern = "[0-9]{4}-[0-9]{5}"
End With

prjNumCheck = regex.Test(eStr)

End Function

Sub listPrjCell()
Dim i As Long
Set prjDict = CreateObject("Scripting.Dictionary")

For i = 5 To Sheets("DataEntry").Cells(Rows.Count, 1).End(xlUp).Row
    prjDict.Add Item:=Sheets("DataEntry").Cells(i, 1), Key:=Sheets("DataEntry").Cells(i, 1).Value
Next

End Sub

Sub ReportGeneration()

Dim ForApproval As Workbook
Dim Reject As Workbook
Dim ApprovalName As String
Dim RejectName As String
Dim WeekNumber As String
WeekNumber = Range("D2").Value

ApprovalName = "Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " OK for Approval.xls"
RejectName = "Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " Rejected.xls"

Set ForApproval = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ApprovalName

Set Reject = Workbooks.Add
ActiveWorkbook.SaveAs filename:=RejectName

Application.ScreenUpdating = False
Workbooks("CCDB Entry Form").Sheets(1).Activate

On Error GoTo errorhandler
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=5, Criteria1:=WeekNumber
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=4, Criteria1:="by CTL"
Range("A4:P" & Range("A4").End(xlDown).Row).Copy Workbooks("Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " OK for Approval").Sheets(1).Cells(1, 1)

ActiveSheet.ShowAllData
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=5, Criteria1:=WeekNumber
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=6, Criteria1:="Reject"
Range("A4:P" & Range("A4").End(xlDown).Row).Copy Workbooks("Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " Rejected").Sheets(1).Cells(1, 1)

errorhandler: Exit Sub

Application.ScreenUpdating = True

End Sub

Hope it helps

Regards

HanSam · Nov 15, 2016

@PCosta87

Did you get this to run on your end? I have tried numerous time but it doesn't seem to work for me.

PCosta87 said:

Hi @HanSam

Please try the following... the CCDB module should read:

Code:

Option Explicit
Public prjDict As Object

Sub Button3_Click()

frmCCDB.Show vbModeless

On Error Resume Next

End Sub

Public Function prjNumCheck(eStr As String) As Boolean

Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")

With regex
    .Pattern = "[0-9]{4}-[0-9]{5}"
End With

prjNumCheck = regex.Test(eStr)

End Function

Sub listPrjCell()
Dim i As Long
Set prjDict = CreateObject("Scripting.Dictionary")

For i = 5 To Sheets("DataEntry").Cells(Rows.Count, 1).End(xlUp).Row
    prjDict.Add Item:=Sheets("DataEntry").Cells(i, 1), Key:=Sheets("DataEntry").Cells(i, 1).Value
Next

End Sub

Sub ReportGeneration()

Dim ForApproval As Workbook
Dim Reject As Workbook
Dim ApprovalName As String
Dim RejectName As String
Dim WeekNumber As String
WeekNumber = Range("D2").Value

ApprovalName = "Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " OK for Approval.xls"
RejectName = "Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " Rejected.xls"

Set ForApproval = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ApprovalName

Set Reject = Workbooks.Add
ActiveWorkbook.SaveAs filename:=RejectName

Application.ScreenUpdating = False
Workbooks("CCDB Entry Form").Sheets(1).Activate

On Error GoTo errorhandler
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=5, Criteria1:=WeekNumber
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=4, Criteria1:="by CTL"
Range("A4:P" & Range("A4").End(xlDown).Row).Copy Workbooks("Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " OK for Approval").Sheets(1).Cells(1, 1)

ActiveSheet.ShowAllData
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=5, Criteria1:=WeekNumber
Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=6, Criteria1:="Reject"
Range("A4:P" & Range("A4").End(xlDown).Row).Copy Workbooks("Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " Rejected").Sheets(1).Cells(1, 1)

errorhandler: Exit Sub

Application.ScreenUpdating = True

End Sub

Hope it helps

Regards

PCosta87 · Nov 15, 2016

HanSam said:
@PCosta87

Did you get this to run on your end? I have tried numerous time but it doesn't seem to work for me.

@HanSam

It does work here... not really sure what is wrong on your end.
I am uploading the file with the code in place... just press "Generate reports" and see if it works

Please let me know

Regards

HanSam · Nov 16, 2016

@PCosta87, it doesn't seem to be working. I am running into a Run-time error

Subscript out of range

PCosta87 said:
@HanSam

It does work here... not really sure what is wrong on your end.
I am uploading the file with the code in place... just press "Generate reports" and see if it works

Please let me know

Regards

PCosta87 · Nov 16, 2016

HanSam said:
@PCosta87, it doesn't seem to be working. I am running into a Run-time error

Subscript out of range

Hi,

Very strange... does it highlight any line of code when you press debug?
This Subscript out of range can occur when you reference something that does not exist, just as an example, if we used sheets("A").activate and there was no sheet A

Try hitting debug and let me know what it highlights please

Regards

HanSam · Nov 16, 2016

Yes actually. See below

PCosta87 said:
Hi,

Very strange... does it highlight any line of code when you press debug?
This Subscript out of range can occur when you reference something that does not exist, just as an example, if we used sheets("A").activate and there was no sheet A

Try hitting debug and let me know what it highlights please

Regards

PCosta87 · Nov 16, 2016

HanSam said:
Yes actually. See below

View attachment 36142

Make sure the file name is "CCDB Entry Form"... when saving the file to your PC it may have changed the name

HanSam · Nov 16, 2016

I tried it again, and is still not working. I tried changing the file name to CCDB Entry Form.xlsm and the autofilter worked however, the data is not being copied to the generated files.

PCosta87 · Nov 16, 2016

HanSam said:
I tried it again, and is still not working. I tried changing the file name to CCDB Entry Form.xlsm and the autofilter worked however, the data is not being copied to the generated files.

Any chance we can do a teamviewer session?

PCosta87 · Nov 16, 2016

Something else came to mind...

Just for debugging purposes, before running the code try deleting the generated files (if there is any), in this case:
Gatekeeper IMS_2016_DSC_CW46 OK for Approval
Gatekeeper IMS_2016_DSC_CW46 Rejected

Select 46 on the dropdown, replace CCDB module code with this slightly tweaked one and then try running:

Code:

Option Explicit
Public prjDict As Object

Sub Button3_Click()

frmCCDB.Show vbModeless

On Error Resume Next

End Sub

Public Function prjNumCheck(eStr As String) As Boolean

Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")

With regex
    .Pattern = "[0-9]{4}-[0-9]{5}"
End With

prjNumCheck = regex.test(eStr)

End Function

Sub listPrjCell()
Dim i As Long
Set prjDict = CreateObject("Scripting.Dictionary")

For i = 5 To Sheets("DataEntry").Cells(Rows.Count, 1).End(xlUp).Row
    prjDict.Add Item:=Sheets("DataEntry").Cells(i, 1), Key:=Sheets("DataEntry").Cells(i, 1).Value
Next

End Sub

Sub ReportGeneration()

Dim ForApproval As Workbook
Dim Reject As Workbook
Dim ApprovalName As String
Dim RejectName As String
Dim WeekNumber As String
WeekNumber = Range("D2").Value

ApprovalName = "Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " OK for Approval.xls"
RejectName = "Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " Rejected.xls"

Set ForApproval = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ApprovalName

Set Reject = Workbooks.Add
ActiveWorkbook.SaveAs filename:=RejectName

Application.ScreenUpdating = False
Workbooks("CCDB Entry Form").Sheets(1).Activate

    With Sheets(1)
        If .FilterMode = True Then
            .ShowAllData
        End If
      
        Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=5, Criteria1:=WeekNumber
        Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=4, Criteria1:="by CTL"
        Range("A4:P" & Range("A4").End(xlDown).Row).Copy Workbooks("Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " OK for Approval").Sheets(1).Cells(1, 1)
      
        If .FilterMode = True Then
            .ShowAllData
        End If
      
        Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=5, Criteria1:=WeekNumber
        Range("A4:P" & Range("A4").End(xlDown).Row).AutoFilter Field:=6, Criteria1:="Reject"
        Range("A4:P" & Range("A4").End(xlDown).Row).Copy Workbooks("Gatekeeper IMS_2016_DSC_CW" & WeekNumber & " Rejected").Sheets(1).Cells(1, 1)
    End With

Application.ScreenUpdating = True

End Sub

Let me know how it goes

Regards

jindon · Nov 16, 2016

HanSam said:
For the file that says OK for Approval, these should be the filters

Week (Based on the chosen week number on the dropdown list)

Date when processed (Should be "by CTL")

For the file that says Reject, these should be the filters

Week (Based on the chosen week number on the dropdown list)

Status (Reject)

See if this is how you wanted.

Code:

Sub test()
    Dim e, myWk As Long, rng As Range
    Application.ScreenUpdating = falae
    With ThisWorkbook.Sheets("dataentry")
        myWk = .[d2].Value
        With .[a4].CurrentRegion
            Set rng = .Offset(, .Columns.Count + 2).Range("a1:a2")
            For Each e In Array(Array("d5", """by CTL""", "OK for Approval"), Array("f5", """Reject""", "Reject"))
                Workbooks.Add
                ActiveWorkbook.SaveAs .Parent.Parent.Path & "\" & e(2) & ".xlsx"
                rng.Range("a2").Formula = "=and(e5=" & myWk & "," & e(0) & "=" & e(1) & ")"
                .AdvancedFilter 2, rng, Workbooks(e(2) & ".xlsx").Sheets(1).Cells(1)
                Workbooks(e(2) & ".xlsx").Close True
            Next
            rng.Clear
        End With
    End With
    Application.ScreenUpdating = True
End Sub

report generation

HanSam

Member

Attachments

PCosta87

Well-Known Member

HanSam

Member

PCosta87

Well-Known Member

Attachments

HanSam

Member

PCosta87

Well-Known Member

HanSam

Member

PCosta87

Well-Known Member

HanSam

Member

PCosta87

Well-Known Member

PCosta87

Well-Known Member

jindon

Well-Known Member