Excel VBA based

Lakshmi Polisetti 20 Reputation points
2025-10-01T15:17:34.3466667+00:00
Option Explicit
Public Sub Consolidate_Event_Research_And_Process()
    On Error GoTo CleanFail
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Dim downloadsPath As String: downloadsPath = GetDownloadsPath()
    ' --- Find Event Research files ---
    Dim fileA As String, fileB As String
    If Not PickFilesPerRules(downloadsPath, fileA, fileB) Then
        ' allow user to pick one or two files
        If Not PickOneOrTwoFiles(fileA, fileB) Then GoTo CleanFail
    Else
        Dim msg As String, ans As VbMsgBoxResult
        msg = "Use these files?" & vbCrLf & vbCrLf & _
              "1) " & fileA & vbCrLf & _
              "2) " & fileB
        ans = MsgBox(msg, vbQuestion + vbYesNo, "Confirm Event Research Files")
        If ans = vbNo Then
            ' allow user to pick one or two files
            If Not PickOneOrTwoFiles(fileA, fileB) Then GoTo CleanFail
        End If
    End If
    ' --- If only one file was chosen, confirm proceeding with single file ---
    If Len(fileA) > 0 And Len(fileB) = 0 Then
        Dim singleAns As VbMsgBoxResult
        singleAns = MsgBox("Only one file was selected." & vbCrLf & _
                           "Do you want to proceed with a single file?", _
                           vbQuestion + vbYesNo, "Single File Selected")
        If singleAns = vbNo Then
            ' let user add a second file
            If Not PickOneOrTwoFiles(fileA, fileB) Then GoTo CleanFail
            ' if still only one picked (or cancelled), fall through; single-file will proceed if fileA present
        End If
    End If
    ' --- Open selected file(s) ---
    Dim wbA As Workbook, wbB As Workbook
    Set wbA = Workbooks.Open(Filename:=fileA)
    Dim wsA As Worksheet, wsB As Worksheet
    Set wsA = FirstVisibleSheet(wbA)
    ' if a second file exists, consolidate (Blind append B -> A)
    If Len(fileB) > 0 Then
        Set wbB = Workbooks.Open(Filename:=fileB)
        Set wsB = FirstVisibleSheet(wbB)
        ' --- Blind append B -> A ---
        Dim lastRowA As Long, lastColA As Long
        lastRowA = LastUsedRow(wsA)
        lastColA = LastUsedCol(wsA)
        Dim lastRowB As Long, lastColB As Long
        lastRowB = LastUsedRow(wsB)
        lastColB = LastUsedCol(wsB)
        If lastRowB >= 2 And lastColB >= 1 Then
            wsB.Range(wsB.Cells(2, 1), wsB.Cells(lastRowB, lastColB)).Copy _
                Destination:=wsA.Cells(lastRowA + 1, 1)
        End If
        wbB.Close SaveChanges:=False
    End If
    ' recompute A after optional append
    Dim lastRowA As Long, lastColA As Long
    lastRowA = LastUsedRow(wsA)
    lastColA = LastUsedCol(wsA)
    If lastRowA < 1 Or lastColA < 1 Then GoTo AfterProcessing
    ' --- Delete "Date Last Amount Recorded in ORE" column ---
    Dim oreCol As Long
    oreCol = FindHeaderCol(wsA, "Date Last Amount Recorded in ORE")
    If oreCol > 0 Then
        wsA.Columns(oreCol).EntireColumn.Delete
        lastColA = LastUsedCol(wsA)
    Else
        If Not AskContinue("Header 'Date Last Amount Recorded in ORE' not found. Continue anyway?") Then GoTo AfterProcessing
    End If
    ' --- Filter blanks in "First Effective Date" ---
    Dim fedCol As Long
    fedCol = FindHeaderCol(wsA, "First Effective Date")
    Dim filterApplied As Boolean: filterApplied = False
    If fedCol = 0 Then
        If Not AskContinue("Header 'First Effective Date' not found. Continue without filtering?") Then GoTo AfterProcessing
    Else
        Dim dataRange As Range
        Set dataRange = wsA.Range(wsA.Cells(1, 1), wsA.Cells(lastRowA, lastColA))
        dataRange.AutoFilter Field:=fedCol, Criteria1:="="
        filterApplied = True
        If Not HasVisibleDataRows(wsA, dataRange) Then
            If Not AskContinue("'First Effective Date' has no blanks. Continue anyway?") Then
                wsA.AutoFilterMode = False
                GoTo AfterProcessing
            End If
            wsA.AutoFilterMode = False
            filterApplied = False
        End If
    End If
    ' --- Ensure "Comments" column exists ---
    Dim commentsCol As Long
    commentsCol = EnsureCommentsColumn(wsA)
    ' --- Discovery Date checks ---
    Dim discCol As Long
    discCol = FindHeaderCol(wsA, "Discovery Date")
    If discCol = 0 Then
        If Not AskContinue("Header 'Discovery Date' not found. Continue without 60-day checks?") Then GoTo AfterProcessing
        GoTo SaveAndFinish
    End If
    Dim effDate As Date: effDate = EffectiveDateByShift()
    ' --- Prepare cumulative workbook ---
    Dim cumulWB As Workbook, cumulWS As Worksheet
    Dim cumulLoaded As Boolean: cumulLoaded = False
    Dim cumulIdCol As Long
    Dim cumulIdDict As Object
    Dim cumulChanged As Boolean: cumulChanged = False
    Dim evIdCol As Long
    evIdCol = FindHeaderCol(wsA, "Event ID")
    If evIdCol = 0 Then
        If Not AskContinue("Header 'Event ID' not found in consolidated. Continue anyway?") Then GoTo AfterProcessing
    End If
    ' --- Clear all old Generate data before appending new ---
    Dim genWS As Worksheet
    Set genWS = ThisWorkbook.Worksheets("Generate")
    ' Clear rows 15 to 500 across the first 500 columns before appending new events
    genWS.Range(genWS.Cells(15, 1), genWS.Cells(500, 500)).ClearContents
    Dim genNextRow As Long: genNextRow = 15
    ' --- Process each visible row ---
    Dim r As Long
    For r = 2 To lastRowA
        If wsA.Rows(r).Hidden = False Then
            Dim discVal As Variant: discVal = wsA.Cells(r, discCol).Value
            If IsDate(discVal) Then
                Dim d As Date: d = CDate(discVal)
                If DateDiff("d", d, effDate) < 60 Then
                    wsA.Cells(r, commentsCol).Value = "Less than 60 days"
                Else
                    Dim eventId As String
                    If evIdCol > 0 Then eventId = Trim$(CStr(wsA.Cells(r, evIdCol).Value))
                    If Len(eventId) = 0 Then
                        wsA.Cells(r, commentsCol).Value = "Review Required"
                    Else
                        ' Load cumulative if not yet loaded
                        If Not cumulLoaded Then
                            Set cumulWB = EnsureOpenCumulativeWB()
                            If cumulWB Is Nothing Then
                                wsA.Cells(r, commentsCol).Value = "Review Required"
                            Else
                                Set cumulWS = FirstVisibleSheet(cumulWB)
                                cumulIdCol = FindHeaderCol(cumulWS, "Event ID")
                                Set cumulIdDict = BuildIdDict(cumulWS, cumulIdCol)
                                cumulLoaded = True
                            End If
                        End If
                        Dim inCumulative As Boolean
                        inCumulative = cumulLoaded And cumulIdDict.Exists(LCase$(eventId))
                        If inCumulative Then
                            wsA.Cells(r, commentsCol).Value = "Already available in the cumulative excel"
                        Else
                            wsA.Cells(r, commentsCol).Value = "Review Required"
                            If Not cumulWB Is Nothing And cumulIdCol > 0 Then
                                ' --- Append full row to cumulative Excel ---
                                Dim cumulLastRow As Long
                                cumulLastRow = LastUsedRow(cumulWS)
                                cumulWS.Rows(cumulLastRow + 1).Insert Shift:=xlDown
                                wsA.Rows(r).Copy cumulWS.Rows(cumulLastRow + 1)
                                cumulChanged = True
                                cumulIdDict(LCase$(eventId)) = True
                                ' --- Append full row to Generate sheet ---
                                wsA.Rows(r).Copy genWS.Rows(genNextRow)
                                genNextRow = genNextRow + 1
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next r
    ' --- Apply borders to newly added rows in Generate sheet ---
    If genNextRow > 15 Then
        With genWS.Range(genWS.Cells(15, 1), genWS.Cells(genNextRow - 1, 500)).Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End If
    ' Save cumulative workbook if changed
    If cumulChanged And Not cumulWB Is Nothing Then cumulWB.Save
SaveAndFinish:
    ' --- Save consolidated file with auto-counter ---
    Dim effSaveDate As Date: effSaveDate = EffectiveDateByShift()
    Dim saveFolder As String: saveFolder = Trim$(GetSettingsPathOrPrompt(ThisWorkbook, "Generate", "B3"))
    If Len(saveFolder) = 0 Then
        MsgBox "No folder selected. Operation cancelled.", vbExclamation
        GoTo CleanFail
    End If
    If Right$(saveFolder, 1) = "\" Then saveFolder = Left$(saveFolder, Len(saveFolder) - 1)
    Dim baseName As String, finalName As String, counter As Long
    baseName = saveFolder & "\" & "Open Redress Pipeline Monitor " & Format$(effSaveDate, "mm.dd.yyyy") & ".xlsx"
    finalName = baseName
    counter = 1
    Do While Dir(finalName) <> ""
        finalName = saveFolder & "\" & "Open Redress Pipeline Monitor " & _
                    Format$(effSaveDate, "mm.dd.yyyy") & " (" & counter & ").xlsx"
        counter = counter + 1
    Loop
    wbA.SaveAs Filename:=finalName, FileFormat:=xlOpenXMLWorkbook
AfterProcessing:
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Process completed successfully!", vbInformation
    Exit Sub
CleanFail:
    On Error Resume Next
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Operation cancelled or failed.", vbExclamation
End Sub
' ===================== NEW HELPER =====================
' Allows selecting one or two files (xlsx or csv)
Private Function PickOneOrTwoFiles(ByRef fileA As String, ByRef fileB As String) As Boolean
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Title = "Select one or two Event Research files"
        .Filters.Clear
        .Filters.Add "Excel (*.xlsx;*.csv)", "*.xlsx;*.csv"
        If .Show <> -1 Then Exit Function           ' user cancelled
        If .SelectedItems.Count = 0 Then Exit Function
        fileA = .SelectedItems(1)
        If .SelectedItems.Count >= 2 Then
            fileB = .SelectedItems(2)
        Else
            fileB = ""
        End If
        PickOneOrTwoFiles = True
    End With
End Function
Microsoft 365 and Office | Excel | For home | Android

Locked Question. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments No comments
{count} votes