Eliminate Weekends and Long weekends

[babar2019]

Hi All,

I have the code below in Red which actually is coded to do something on the 1st of each month. But due to weekends or long weekends, this process is not working and the files are not rolling over whenever the first business day falls on a 2nd 3rd or anything other than the 1st.

Can someone please assist me exclude weekends (Saturday and Sunday) and also long weekends? I can provide the list of holidays if needed

Background is we have an excel report which has a data column in the format mmddyy and the code is looking to see if the mmdd is 01st of the month and then compares to other excel sheet which has worksheet named as 0119 0219.. So whenever it's the 1st of the month, it copies data over from previous month worksheet over to a new worksheet. But what I want is to roll over on the first business day of the month and not just hard coded 01st of the month.

Sub InProcessRecon()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, srcWS As Worksheet, desWS As Worksheet, LastRow As Long, key As Variant, totals As Long, totals1 As Long, totals2 As Long, fVisRow As Long
    Dim RngList As Object, rng As Range, arr As Variant, i As Long, fNames As String, code As Variant, sDate As String, Day1 As String, prevWS As Worksheet
   
    'Source File Sheet name
    Set srcWS = Sheets("QRYLIBA380.CSIPHIST>Sheet1")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    'Opening In Process files based on the value coming from source file
    fNames = "SIGNAPAY LTD IN PROCESS ACCOUN,In Process DDA Recon - SignaPay," & _
             "EPT 6001 IN PROCESS ACCOUNT,In Process DDA Recon - EPS," & _
             "APS IN PROCESS ACCOUNT,In Process DDA Recon - APS," & _
             "PAYMENT WORLD IN PROCESS ACCT,In Process DDA Recon - Payment World," & _
             "TRISOURCE IN PROCESS ACCOUNT,In Process DDA Recon - TriSource," & _
             "BANCTEK SOLUTIONS IN PROCESS,In Process DDA Recon - BancTek," & _
             "MERCHANT BANCARD IN PROCESS,In Process DDA Recon - MBN," & _
             "ADVANCE MERCHANT IN PROCESS AC,In Process DDA Recon - DAS," & _
             "2C PROCESSOR IN PROCESS,In Process DDA Recon - 2CP," & _
             "FRONTLINE IN PROCESS ACCOUNT,In Process DDA Recon - FrontLine," & _
             "TITANIUM PROCESSING IN PROCESS,In Process DDA Recon - Titanium Processing," & _
             "ARGUS MERCHANT IN PROCESS ACCT,In Process DDA Recon - Argus," & _
             "INFINITY CAPTIAL LLC IN PROCES,In Process DDA Recon - Choice," & _
             "TITANIUM PAYMENTS IN PROCESS,In Process DDA Recon - Titanium Payments," & _
             "MERCHANT INDUSTRY2 IN PROCESS,In Process DDA Recon - Merchant Industry," & _
             "UNIFIED PAYMENTS IN PROCESS,In Process DDA Recon - Unified," & _
             "ELECTRONIC MERCHANT SYS IN PRO,In Process DDA Recon - EMS Conversion," & _
             "MAVERICK IN PROCESS ACCOUNT,In Process DDA Recon - Maverick," & _
             "PIVOTAL PAYMENTS IN PROCESS,In Process DDA Recon - Nuvei," & _
             "C&H FINANCIAL SERVICES IN PROC,In Process DDA Recon - C&H," & _
             "MERCHANT LYNX SERVICES IN PROC,In Process DDA Recon - Merchant Lynx," & _
             "EVANCE IN PROCESS,In Process DDA Recon - eVance," & _
             "TSYS IN PROCESS ACCOUNT,In Process DDA Recon - TSYS," & _
         "BANKCARD IN PROCESS ACCOUNT,In Process DDA Recon - BankCard,GRANITE PAYMENT ALLIANCE IN PR,In Process DDA Recon - Granite,AUTOSCRIBE CORP IN PROCESS,In Process DDA Recon - AUTOSCRIBE,TRX SERVICES IN PROCESS ACCT,In Process DDA Recon - TRX Merchant Services"
            
        arr = Split(Application.Trim(fNames), ",")
       
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
    Next rng
    For Each key In RngList
        For i = 0 To UBound(arr)
            If arr(i) = key Then
                Set wkbDest = Workbooks.Open(ActiveWorkbook.Path & "\" & arr(i + 1) & ".xlsx")
                With srcWS.Cells(1).CurrentRegion
                    .AutoFilter 1, key
                    fVisRow = srcWS.Range("A1", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
                    sDate = srcWS.Cells(fVisRow, 4)
                    Day1 = Left(Right(sDate, 4), 2)
                   
                    'Roll over data from previous to Current Month when the month rolls over
                    If Day1 = "01" Then
                        If Left(Left(sDate, Len(sDate) - 4) - 1, 1) < 1 Then
                            Set prevWS = Sheets("0" & Left(sDate, Len(sDate) - 4) - 1 & Right(sDate, 2))
                        Else
                            Set prevWS = Sheets(Left(sDate, Len(sDate) - 4) - 1 & Right(sDate, 2))
                        End If
                        With prevWS
                            Set desWS = ActiveWorkbook.Sheets(Format(DateSerial(Right(sDate, 2), Left(sDate, Len(sDate) - 4), Mid(sDate, Len(sDate) - 3, 2)), "mmyy"))
                            totals = .Range("C:C").Find("Reconciliation Totals").Row
                            totals1 = desWS.Range("C:C").Find("Reconciliation Totals").Row
                            RowCount = totals - 10
                            desWS.Cells(totals1, 1).EntireRow.Resize(RowCount).Insert Shift:=xlDown
                            .Range("A10:I" & totals - 1).Copy desWS.Cells(totals1, 1)
                        End With
totals1:
                        Set desWS = ActiveWorkbook.Sheets(Format(DateSerial(Right(sDate, 2), Left(sDate, Len(sDate) - 4), Mid(sDate, Len(sDate) - 3, 2)), "mmyy"))
                        totals1 = desWS.Range("C:C").Find("Reconciliation Totals").Row
                        RowCount = srcWS.[subtotal(103,A:A)] - 1
                        desWS.Cells(totals1, 1).EntireRow.Resize(RowCount).Insert Shift:=xlDown
                        srcWS.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 2)
                        totals2 = desWS.Range("C:C").Find("Reconciliation Totals").Row
                        For Each rng In desWS.Range("B" & totals1 & ":B" & totals2 - 1)
                            rng = Format(DateSerial(Right(rng, 2), Left(rng, Len(rng) - 4), Mid(rng, Len(rng) - 3, 2)), "mm/dd/yy")
                        Next rng
                        With srcWS
                            .Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 5)
                            .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 6)
                            .Range("G2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 3)
                            .Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 4)
                        End With
                        srcWS.Cells(1).AutoFilter
                        totals2 = desWS.Range("C:C").Find("Reconciliation Totals").Row
                        With desWS.Range("B10:B" & totals2 - 1)
                            .Font.Name = "Bookman Old Style"
                            .Font.Color = 10040115
                            .Font.Size = 10
                            .HorizontalAlignment = xlLeft
                        End With
                        With desWS.Range("C10:C" & totals2 - 1)
                            .Font.Name = "Bookman Old Style"
                            .Font.Size = 10
                            .HorizontalAlignment = xlLeft
                        End With
                        With desWS.Range("D10:D" & totals2 - 1)
                            .Font.Name = "Bookman Old Style"
                            .Font.Color = 10040115
                            .Font.Size = 10
                            .HorizontalAlignment = xlLeft
                        End With
                        With desWS.Range("E10:E" & totals2 - 1)
                            .Font.Name = "Bookman Old Style"
                            .Font.Color = 10040115
                            .Font.Size = 10
                            .HorizontalAlignment = xlCenter
                            .Replace "55", "DR"
                            .Replace "78", "DR"
                            .Replace "18", "CR"
                            .Replace "38", "CR"
                        End With
                        With desWS.Range("F10:F" & totals2 - 1)
                            .Font.Name = "Bookman Old Style"
                            .Font.Color = 10040115
                            .Font.Size = 10
                        End With
                        With desWS
                            For Each code In .Range("E10:E" & totals2 - 1)
                                If code = "DR" Then
                                    If code.Offset(, 1) > 0 Then
                                        code.Offset(, 1) = "-" & code.Offset(, 1)
                                    End If
                                    code.Offset(, 1).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
                                ElseIf code = "CR" Then
                                    code.Offset(, 1).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
                                End If
                            Next code
                        End With
                        With desWS
                            .Range("G10:I10").Copy
                            .Range("G10:I" & totals2 - 1).PasteSpecial Paste:=xlPasteFormulas
                            .Range("F" & totals2).FormulaR1C1 = "=SUM(INDIRECT(""F10:F""&ROW()-1))"
                            .Range("G" & totals2).FormulaR1C1 = "=SUM(INDIRECT(""G10:G""&ROW()-1))"
                            .Range("H" & totals2).FormulaR1C1 = "=SUM(INDIRECT(""H10:H""&ROW()-1))"
                        End With
                    Else
                        GoTo totals1
                    End If
                End With
            End If
        Next i
        wkbDest.Close True
    Next key
    MsgBox ("In Process recon job completed successfully.  Please check the Files.")
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[ranman256]

I have a table of holidays. Then when I scan thru the dates, it ignores those if in the holiday list, and if the date is a weekend:

public sub ScanDates()
dim colHolidays as new collection

On Error GoTo errBadDates
   'fill colHolidays from list
Set colHolidays = FillHolidayList()  'fill your holidays here

'scan thru all date range
vStartDate = "12/18/2019"
vEndDate = "12/24/2019"
vDate = vStartDate
While CDate(vDate) <= CDate(vEndDate)
   If Format(vDate, "w") = vbSaturday Or Format(vDate, "w") = vbSunday Then
      'ignore weekend
       Debug.Print "weekend: " & vDate
   Else
      sDte = vDate
      If colHolidays(sDte) = CStr(vDate) Then
           'ignore holidays
             Debug.Print "holiday: " & vDate
       Else
goodDate: 'process date here
            Debug.Print vDate
       End If
   End If
    vDate = DateAdd("d", 1, vDate)  'get next date
Wend
Exit Sub
errBadDates:
If Err = 5 Then Resume goodDate
End Sub

 

[babar2019]

Hi @ranman256 Where would you fit the code into mine?Also Can I hard code the holiday list inside the VBA ? Users run this via Macro. They don't have like a form or anything.

 

[babar2019]

Hi,

In the above code, Currently the macro copies the previous worksheet data into a new worksheet whenever it sees the day as "01".

Is there a way the user can change this manually every month based on whatever the first business day it is from "01" to "02" or "03" etc and the macro will still run fine?
I'm testing it on a file where the source file will have a date of "010220" because "02" is the first business day for January 2020, The macro does not roll the data over from "1219" worksheet over to "0120" worksheet.

Can you please help?

 

[ranman256]

you could use 2 cells on a screen to enter the startdate / enddate
b2=startdate
b3 = enddate
the list of holidays in another cell range ,i.e: H:1-99
click button to run the macro.

then adjust code:
'scan thru all date range
vStartDate = range("B2").value
vEndDate = range("B3").value