VBA for Cash Book

MCashBook.bas

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Author        : Arab Salem
' Gist          : https://gist.github.com/arabsalem/7928008
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Text
Public Const DesktopFolder As String = "\DRC-CashBooks-CoverSheets\"
Public Const FirstRowIndex As Integer = 13
Public Const DescriptionIndex As Integer = 7
Public Const ChequeNumberIndex As Integer = 17
Public Const DescriptionLimit As Integer = 50
Public Const CoverSheetHeaderRowNo As Integer = 8
Public Const adOpenStatic = 3
Public Const adLockOptimistic = 3
Public Const CashBookCurrency = "B6"
Public wb As Workbook
Public CashBook As Worksheet
Public CoverSheet As Worksheet

Public Sub MakePDFCoverSheet()
    HandleCoverSheet (True)
End Sub

Public Sub MakeCoverSheet()
    HandleCoverSheet (False)
End Sub

Private Function CheckingIfAFolderExists() As Boolean

Dim FSO
Dim File
Dim sFolder As String
 
sFolder = CreateObject("WScript.Shell").specialfolders("Desktop") & "\DRC-Cash-Books\"
Set FSO = CreateObject("Scripting.FileSystemObject")
 
If FSO.FolderExists(sFolder) Then
    CheckingIfAFolderExists = True
Else
    CheckingIfAFolderExists = False
End If
 
End Function

Private Function GeneratePDFFileName(strDocumentNumber As String)
    Dim k As Integer
    Dim fName As String
    Dim File
    Dim Filename As String
    Dim fs
    Dim Folder As String
    
    Filename = strDocumentNumber & ".pdf"
    Folder = CreateObject("WScript.Shell").specialfolders("Desktop") & DesktopFolder
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'check if folder already exists
    If fs.FolderExists(Folder) Then
    Else
        Set File = fs.CreateFolder(Folder)
    End If
    
    'check if file already exists
    If Len(Dir(Folder & Filename, vbNormal)) = 0 Then 'file does not exist
        GeneratePDFFileName = Folder & Filename
    Else
        fName = Filename
        Do Until Len(Dir(Folder & Filename, vbNormal)) = 0
            k = k + 1
            Filename = Replace$(fName, ".pdf", "_" & k & ".pdf")
        Loop
        GeneratePDFFileName = Folder & Filename
    End If
    
End Function


Public Sub HandleCoverSheet(Optional ByVal isPDF As Boolean = False)
On Error GoTo ErrHandler:

    Dim strDocumentNo As String
    Dim intLastRow As Integer
    Dim FilePath As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
        
    ThisWorkbook.Save
    
    strDocumentNo = GetDocumentNumber()
       
    intLastRow = GetLastRow()
    
    Call DeleteExistingCoverSheets
    
    Call AddCoverSheet(strDocumentNo)
    Set CoverSheet = wb.Worksheets(strDocumentNo)
    Call GenerateCoverSheetArray(strDocumentNo, intLastRow)

    If isPDF Then
            FilePath = GeneratePDFFileName(strDocumentNo)
            CoverSheet.ExportAsFixedFormat _
                        Type:=xlTypePDF, _
                        Filename:=FilePath, _
                        Quality:=xlQualityStandard, _
                        IncludeDocProperties:=True, _
                        IgnorePrintAreas:=False, _
                        OpenAfterPublish:=True
    
    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
  Exit Sub
  
ErrHandler:
   MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
   Resume Next
End Sub

Private Sub GenerateCoverSheetArray(strDocumentNo As String, intLastRow As Integer)

    Dim Arr() As Variant
    Dim R As Integer
    Dim C As Integer
    Dim R2 As Integer
    Dim TotalAmount As Double
    
    Set wb = ThisWorkbook
    
    Set CashBook = wb.Worksheets("Cash Book")
    Set CoverSheet = wb.Worksheets(strDocumentNo)
    
    Arr = CashBook.Range("A13:J" & intLastRow).Value
    
    R2 = CoverSheetHeaderRowNo + 1
    TotalAmount = 0
    
    For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
        
        If Arr(R, 2) = CoverSheet.Name Then
            
            CoverSheet.Range("A" & R2).Value = DateSerial(CashBook.Range("B9"), CashBook.Range("B8"), Arr(R, 1)) ' "'" & Arr(R, 1) & "-" & MonthName(CashBook.Range("B8"), True) & "-" & CashBook.Range("B9")
            CoverSheet.Range("B" & R2).Value = Trim(Arr(R, 4))
            CoverSheet.Range("C" & R2).Value = Trim(Arr(R, 5))
            CoverSheet.Range("D" & R2).Value = Trim(Arr(R, 6))
            CoverSheet.Range("E" & R2).Value = Trim(Arr(R, 7))
            CoverSheet.Range("F" & R2).Value = Trim(Arr(R, 10))
            TotalAmount = TotalAmount + Arr(R, 10)
            R2 = R2 + 1
        End If
        Next R
        
        CoverSheet.Range("F1") = "Document No: " & CoverSheet.Name
        CoverSheet.Range("F1").Characters(14, 25).Font.Bold = True
        CoverSheet.Range("F2") = "Total Amount: " & Format(TotalAmount, "standard")
        CoverSheet.Range("F2").Characters(15, 25).Font.Bold = True
        CoverSheet.Range("F3") = "Currency: " & CashBook.Range(CashBookCurrency).Value
        CoverSheet.Range("F3").Characters(10, 5).Font.Bold = True
        
        CoverSheet.Range("F4") = "# of Rows: " & (R2 - CoverSheetHeaderRowNo - 1)
        CoverSheet.Range("F4").Characters(10, 5).Font.Bold = True
        
End Sub

Private Sub AddCoverSheet(strDocumentNo As String)
On Error GoTo ErrHandler:


    Set wb = ThisWorkbook
    Set CashBook = wb.Worksheets("Cash Book")
        
    wb.Worksheets.Add(After:=CashBook).Name = strDocumentNo
    
    Set CoverSheet = wb.Worksheets(strDocumentNo)
    
    CashBook.Shapes("Billede 1").Copy
    
    With CoverSheet
        .Range("A1").PasteSpecial
        .Range("A" & CoverSheetHeaderRowNo).Value = "Date       "
        .Range("A" & CoverSheetHeaderRowNo).Font.Underline = True
        .Range("A" & CoverSheetHeaderRowNo).Select
        
        .Columns(1).NumberFormat = "dd-mmm-yy"
        .Columns(1).HorizontalAlignment = xlLeft
        
        .Range("B" & CoverSheetHeaderRowNo).Value = "Acct No.   "
        .Range("B" & CoverSheetHeaderRowNo).Font.Underline = True
        .Columns(2).NumberFormat = "@"
        
        .Range("C" & CoverSheetHeaderRowNo).Value = "Project No."
        .Range("C" & CoverSheetHeaderRowNo).Font.Underline = True
        
        .Range("D" & CoverSheetHeaderRowNo).Value = "Budget Line"
        .Range("D" & CoverSheetHeaderRowNo).Font.Underline = True
        .Columns(4).NumberFormat = "@"
        
        .Range("E" & CoverSheetHeaderRowNo).Value = "Description"
        .Range("E" & CoverSheetHeaderRowNo).Font.Underline = True
        
        .Range("F" & CoverSheetHeaderRowNo).Value = "Amount"
        .Range("F" & CoverSheetHeaderRowNo).Font.Underline = True
        .Columns(6).NumberFormat = "#,##0.00"
        .Columns(6).HorizontalAlignment = xlRight
        
        .Range("A" & CoverSheetHeaderRowNo & ":F" & CoverSheetHeaderRowNo).Font.Bold = True
        
        .Columns(1).ColumnWidth = 11
        .Columns(2).ColumnWidth = 9
        .Columns(3).ColumnWidth = 13
        .Columns(4).ColumnWidth = 12
        .Columns(5).ColumnWidth = 50
        .Columns(6).ColumnWidth = 20

                With .PageSetup
                    .PrintTitleRows = "$1" & ":$" & CoverSheetHeaderRowNo
                    .PrintTitleColumns = ""
                    .LeftMargin = Application.CentimetersToPoints(0.7)
                    .RightMargin = Application.CentimetersToPoints(0.7)
                    .TopMargin = Application.CentimetersToPoints(1)
                    .BottomMargin = Application.CentimetersToPoints(0.7)
                    .HeaderMargin = Application.CentimetersToPoints(0.2)
                    .FooterMargin = Application.CentimetersToPoints(0.4)
                    .LeftHeader = ""
                    .CenterHeader = "&BCover Sheet&B"
                    .RightFooter = "Page &P of &N"
                    .PaperSize = xlPaperA4
                    .Orientation = xlPortrait 'xlLandscape
                    .Zoom = False
                    .FitToPagesWide = 1
                    .FitToPagesTall = 20
                End With
                
        End With
    
    Exit Sub
    
ErrHandler:
   MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
   Resume Next
     
End Sub

Sub JoinChequeNumber()
On Error GoTo ErrHandler:

    Dim RowIndex As Integer
    Dim CheckPosition As Integer
    Dim i As Variant
    Dim LastRow As Integer
    
    Set wb = ThisWorkbook
    
    Set CashBook = wb.Worksheets("Cash Book")
    
    i = 0
          
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    LastRow = GetLastRow()
    For RowIndex = FirstRowIndex To LastRow
        If Len(Trim(Cells(RowIndex, ChequeNumberIndex).Value)) > 0 Then
            CheckPosition = InStr(Cells(RowIndex, DescriptionIndex).Value, Cells(RowIndex, ChequeNumberIndex).Value)
            If CheckPosition = 0 Then
                Cells(RowIndex, DescriptionIndex).Value = Left("Chq " & Cells(RowIndex, ChequeNumberIndex).Value & " " & Cells(RowIndex, DescriptionIndex).Value, DescriptionLimit)
                i = i + 1
            End If
        End If
    Next RowIndex
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox i & " entries had Cheque No. added to the description", vbInformation, "Cheque Number(s)"
    Exit Sub
    
ErrHandler:
   MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
   Resume Next
   
End Sub

Public Sub PopulateListbox()
    On Error GoTo ErrHandler:
    
    ThisWorkbook.Save
        
    Dim cn As Object
    Dim rs As Object
    Dim strfile As String
    Dim strSheet As String
    Dim strCon  As String
    Dim strSQL As String
    Dim NoOfRecords As Integer
    Dim strSheetRange As String
    
    Set wb = ThisWorkbook
    
    Set CashBook = wb.Worksheets("Cash Book")
  
    Selection.Offset(1, 0).Select
    
    strSheetRange = "[" & CashBook.Name & "$" & "A" & FirstRowIndex & ":J" & GetLastRow() & "]"  '[Cash Book$A13:J20]
    
    strfile = wb.FullName
    
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strfile & _
    ";Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"";"
    
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    cn.Open strCon, cn
    
    strSQL = "SELECT F5 as Project, F6 as BL, Count(F2) as 'Count', Format(SUM(F10),'Standard') as Total FROM " & strSheetRange & _
    " WHERE F2 like '" & "p" & "%' " & _
    " GROUP BY F5, F6"
    
    rs.Open strSQL, cn, adOpenStatic, adLockOptimistic
    
    NoOfRecords = rs.RecordCount
    
    If rs.BOF And rs.EOF Then
        MsgBox "No records in recordset.", vbExclamation, "Cash Book Summary"
        End
    Else
        With SummaryForm.ListBox1
            .Clear
            .ColumnCount = rs.Fields.count
            .ColumnWidths = "60;60;20;90"
            .column = rs.GetRows(NoOfRecords)
            .ColumnHeads = False
            .TextAlign = fmTextAlignRight
        End With
    End If
    
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
ErrHandler:
    MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
    Resume Next
End Sub


Private Sub DeleteExistingCoverSheets()
    Dim ws As Worksheet, flg As Boolean
    For Each ws In Sheets
        If LCase(ws.Name) Like "p???-*" Then
            ws.Delete
        End If
    Next
End Sub

Private Sub SelectCoverSheets()
    Dim ws As Worksheet, flg As Boolean
    For Each ws In Sheets
        If LCase(ws.Name) Like "p???-*" Then
            ws.Select Not flg
            flg = True
        End If
    Next
End Sub

Private Function GetLastRow()

    Set wb = ThisWorkbook
    
    Set CashBook = wb.Worksheets("Cash Book")

    GetLastRow = RangeNameAddress(CashBook, "end", "row") - 2
End Function

Private Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = (Sheets(WorksheetName).Name <> "")
    On Error GoTo 0
End Function

Private Function RangeNameAddress(wks As Worksheet, strRng As String, strRowOrAddress As String) As String
    Dim strName As String
       
    If SheetRangeExists(wks, strRng) Then
    Select Case strRowOrAddress
    Case "address"
        RangeNameAddress = wks.Range(strRng).Address
    Case "row"
        RangeNameAddress = wks.Range(strRng).row
    End Select
        Else
            MsgBox ("'End' Range is missing in the Cash Book Sheet")
            End
    End If
End Function

Private Function SheetRangeExists(wks As Worksheet, sRng As String) As Boolean
    On Error Resume Next
    SheetRangeExists = Len(wks.Range(sRng).Address)
    Err.Clear
End Function

Private Function StartsWith(str As String, start As String) As Boolean
     Dim startLen As Integer
     startLen = Len(start)
     StartsWith = (Left(Trim(UCase(str)), startLen) = UCase(start))
End Function

Private Sub Highlight_Duplicates(Values As Range)
Dim cell

For Each cell In Values
    If WorksheetFunction.CountIf(Values, cell.Value) > 1 Then
        cell.Interior.ColorIndex = 6
        MsgBox (cell.Value)
    Else
    MsgBox (cell.Value)
    End If
Next cell
End Sub

Public Sub ShowSummary()
    SummaryForm.Show
End Sub

Private Function GetDocumentNumber()

    Dim strDocumentNumber As String
    strDocumentNumber = Trim(ActiveCell.Value)
    If strDocumentNumber Like "p???-*" Then
        GetDocumentNumber = strDocumentNumber
    Else
        MsgBox "Please select a valid 'Document Number'", vbCritical, "Cover Sheet"
        End
        
    End If
End Function

Steps

(0) start with your latest cash book

(1) download the 3 files attached to a folder on your desktop

(2) open the VBA Editor by right clicking on the "Cash Book" sheet name and then select "View Code"

(3.1) Find the "Modules" folder from the top left window 

(3.2) right click on "Module1" and select "Remove Module1" and answer "No" when asked if you want to export

(3.3) right click on "Module2" and select "Remove Module2" and answer "No" when asked if you want to export

(4.1) in the VBA editor, right click on the project and select 'Import File' the select "MCashBook.bas" from you folder in step (1)

(4.2) in the VBA editor, right click on the project and select 'Import File' the select "SummaryForm.frm" from you folder in step (1)

(5) delete the current buttons in the "Cash Book" sheet and create 4 new buttons

(6.1) right click on the each button, select "Edit Text" and name them as below:
1st => Cover Sheet
2nd => Cover Sheet (PDF)
3rd => Copy Cheque Nos. to Description
4th => Show Summary

(6.2) right click on the each button, select "Assign Macro" as shown below:
1st => MakeCoverSheet
2nd => MakePDFCoverSheet
3rd => Copy Cheque Nos. to Description
4th => ShowSummary

(7) in the VBA editor, under the Menu "Debug" click on "Compile" and make sure no errors are returned

SummaryForm.frm

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} SummaryForm 
   Caption         =   "Cash Book Summary"
   ClientHeight    =   8190
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6120
   OleObjectBlob   =   "SummaryForm.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "SummaryForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False



Private Sub CmdExit_Click()
    Unload Me
End Sub


Private Sub UserForm_Initialize()
    Call PopulateListbox
End Sub

Hello dear,
I really want to know how these functions are working and if you have comments about it how you decided about the variable and what they are for? thanks for your time and your support if you could help me i really liked what you did and i want to learn this kind of connecting VB with Excel and access as well.for example what are
"
Public Const adOpenStatic = 3
Public Const adLockOptimistic = 3
Public wb As Workbook
Public CashBook As Worksheet
Public CoverSheet As Worksheet
Public Const CoverSheetHeaderRowNo As Integer = 8
" these for i mean in which time they are working.!!???
Best regards,
Yaseen Kamala