Develop a macro to solve below problem

[SamT]

I have tried to understand and fix the orignial code. Then I refactored it for easier troubleshooting and maintenance. I have attached a file of the Exported code with my white space formatting, which will make more sense than Mark007's white space. Unzip it to import it into VBA

Note: Since I am unable to review all the code and workbooks, there may still be some errors.
Note: for some reason, With this code all Range.Value uses display as lower case, ("value") This does not happen elsewhere in the same workbook

Attachment 15367

Module Level Declarations

Option Explicit

Dim FinalPM As String
'Dim OFolder As String 'Not used
Dim FinalOutput As String
 
Dim DailyPM As String
Dim DPMfolder As String
Dim wbDPM As Workbook 'From B4
Dim wsDPM As Worksheet

'Final Matched
Dim FPMfolder As String
Dim wbFPM As Workbook
Dim wsFPM As Worksheet

Dim wbFPO As Workbook
Dim wsFPO1 As Worksheet
Dim wsFPO2 As Worksheet
Dim wsFPO3 As Worksheet

Dim wbTool As Workbook
Dim wsTool As Worksheet

Dim Merchant As String
Dim Acronym As String
Dim FSPLIT As Variant

Dim ProcOK As Boolean
Public PressedState As Boolean  ' to trap Esc or Cancel button pressed

'Placed at Module level for consistant style
Dim tStart As Date  ' start timer
Dim tStop As Date  ' stop timer
Dim tEnd As Date  ' estimated end time
Dim tmidnite As Date  ' extra timer Value if the process is started before and ends after midnight (next day)

Dim DPMrng As Range  ' range will refer to the data in the Daily Price Master file receiveed from Supplier
Dim DPMRow As Long
Dim lstDPMRow As Long

Dim FPMrng As Range  ' range will refer to the data in the Final Product Mapping file
Dim FPMRow As Long
Dim lstFPMRow As Long

Dim FPO1Row As Long
Dim FPO2Row As Long
Dim FPO3Row As Long

Public Sub MapAndConsolidate()

  With Application
   .ScreenUpdating = False
   .EnableEvents = False
   .Calculation = xlCalculationManual
   .EnableCancelKey = xlDisabled
  End With

'''' Initialize Variables and set up Project wokbooks
  If Initilize_PublicVariables_Failed Then GoTo exitNoGo
  If Not ContinueRequested Then GoTo exitSub
  If Not Add_wbFPO_WorkSheets Then GoTo exitSub
  
  On Error GoTo err_handler
  Application.EnableCancelKey = xlErrorHandler
  
''''Not sure if used
  Show ProgressForm
  
''''Main Code
  For DPMRow = 2 To lstDPMRow
    If DPMRow Mod 50 = 0 And lstDPMRow - DPMRow > 50 Then
      tEnd = Format(time2End(lstDPMRow - DPMRow, DPMRow, tStart), "HH:mm:ss")
      Application.StatusBar = "PriceMapping Consolidation ... " & Format(DPMRow / lstDPMRow, "#0.0%") & IIf(DPMRow >= 50, Space(5) & "estimated completion time remaining: " & tEnd, "")
    End If
         
     Set FPMrng = wsFPM.Range("A:A").Find(What:=(wsDPM.Cells(DPMRow, 1).value), LookIn:=xlValues, LookAt:=xlWhole)
     If Not FPMrng Is Nothing Then
      PMPartI FPMrng.Row
      ' Part I: Price Information for System Upload where Price information is available
 
     Else
      PMPart2
      ' Part II: populate all items from Sheet 1 where price information was not found in Sheet 2
     ' no code written for PMPart3
     'PMPart3 ' Part III: New worksheet to populate all duplicate items from Sheet 1 where price information was not found in Sheet 2
    
     End If
   
''''Check if Cancel or Escape Key was Pressed. Code not available for review
   If PressedState = True Then
    Select Case MsgBox("You have pressed 'Esc' or 'Cancel'!" & vbCrLf & vbCrLf & _
        "Do you wish to stop the Price Mapping process?", vbExclamation + vbYesNo + vbDefaultButton2, "STOP PRICEMAPPING PROCESS?")
      Case Is = vbYes
        Exit For
      Case Else
        Pressed State = False
    End Select
   End If
    
  Next DPMRow
'''' End Main Code

  Err.Clear
  On Error GoTo 0
  
  wsFPO1.Cells.Columns.AutoFit
  wsFPO2.Cells.Columns.AutoFit
  wsFPO3.Cells.Columns.AutoFit
  GoTo EndRoutine
  
err_handler:
  If Err.Number = 18 Then Pressed State = True '<--- Where is the end if for this if
  Err.Clear
  Resume
  
EndRoutine:
  wbFPO.Save
  tStop = Format(Now(), "hh:mm:ss")
  ProcOK = True
  GoTo exitSub
  
exitNoGo:
  MsgBox "One or more data files was not found or is not available!", vbExclamation, "OPERATION ABORTED"

Exit Sub:
  Application.ScreenUpdating = True
  Application.StatusBar = False
  Err.Clear
  
  On Error Resume Next
    wbFPM.Close = False
    wbDPM.Close = False
    Set wbFPM = Nothing
    Set wbDPM = Nothing
    Set wbFPO = Nothing
  On Error GoTo 0
  
  If ProcOK Then
    wsTool.Range("B2:B5").ClearContents
    MsgBox "Process started : " & tStart & vbCrLf & "Process ended at: " & tStop & vbCrLf & _
      "Time elapsed: " & IIf(Hour(tStop) >= Hour(tStart), Format(tStop - tStart, "hh:mm:ss"), _
      Format((tmidnite - tStart) + tStop, "hh:mm:ss")), vbInformation, "Price Mapping completed sucessfully!"
  Else
    MsgBox "Price Mapping not completed!", vbExclamation, "Price Mapping failed!"
  End If
  
  wbTool.Save
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .EnableCancelKey = xlInterrupt
  End With
End Sub

Private Function Initilize_PublicVariables_Failed() As Boolean
'Function set True on error
ProcOK = False
PressedState = False
tStart = Format(Now(), "hh:mm:ss")
tmidnite = Format(TimeValue("23:59:59"), "hh:mm:ss")
   
  Set wbTool = Workbooks("PriceMappingTool.xlsm")
  Set wsTool = wbTool.Sheets("Main")
  
  If Len(Trim(wsTool.Range("B2"))) = 0 Or Len(Trim(wsTool.Range("B3"))) = 0 _
  Or Len(Trim(wsTool.Range("B4"))) = 0 Or Len(Trim(wsTool.Range("B5"))) = 0 Then
      MsgBox "Please verify THAT all the input values have been entered!", vbCritical, "OPERATION ABORTED !!!"
      Exit Function
  End If
  
  Application.ScreenUpdating = False
   
  With wsTool
     Merchant = .Range("B2").value
     Acronym = findAcronym(wsTool.Range("B2").value)
       If Len(Trim(Acronym)) = 0 Then Acronym = "XXX"
     FinalOutput = "Final_Output-" & Format(Now(), "dd-mm-yyyy-HHmm") & "_" & Trim(Acronym) & ".xlsx"

'Possible Errors below:
     FSPLIT = Split(.Range("B3").value, Application.PathSeparator)
     FinalPM = FSPLIT(CInt(UBound(FSPLIT))) 'File Name after Path. CInt will return error if not a number
     FPMfolder = Replace(.Range("B3").value, FinalPM, "")
      If Right(FPMfolder, 1) <> Application.PathSeparator Then _
         FPMfolder = FPMfolder & Application.PathSeparator
         'By Definition in code above, FPMFolder MUST already end with PathSepearator
         'If Range <> Full Name then other PAth must be found
     
     FSPLIT = Split(.Range("B4").value, Application.PathSeparator)
     DailyPM = FSPLIT(CInt(UBound(FSPLIT))) 'See above comments
     DPMfolder = Replace(.Range("B4").value, DailyPM, "")
      If Right(DPMfolder, 1) <> Application.PathSeparator Then _
         DPMfolder = DPMfolder & Application.PathSeparator
         'See above comments
     
     'OFolder = .Range("B5").value
      'If Right(OFolder, 1) <> Application.PathSeparator Then _
         OFolder = OFolder & Application.PathSeparator
  End With
  
  On Error Resume Next
  Set wbFPM = Workbooks(FinalPM)
  If wbFPM Is Nothing Then Set wbFPM = Workbooks.Open(Filename:=FPMfolder & FinalPM, ReadOnly:=True)
  If wbFPM Is Nothing Then GoTo exitNoGo
   Set wsFPM = wbFPM.Sheets("Final Matched")
   lstFPMRow = WorksheetFunction.Max(2, wbFPM.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row) ' determine the last filled row of FPM file
   lstDPMRow = WorksheetFunction.Max(2, wbDPM.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row) ' determine the last filled row of DPM file
      
  Set wbDPM = Workbooks(DailyPM)
  If wbDPM Is Nothing Then Set wbDPM = Workbooks.Open(Filename:=DPMfolder & DailyPM, ReadOnly:=True)
  If wbDPM Is Nothing Then GoTo exitNoGo
   Set wsDPM = wbDPM.Sheets(1)
          
  Set wbFOP = Workbooks(FinalOutput)
  If wbFOP Is Nothing Then Set wbFOP = Workbooks.Open(Filename:=filePath & Application.PathSeparator & FinalOutput)
  If wbFOP Is Nothing Then GoTo exitNoGo
  FPO1Row = 1
  FPO2Row = 1
  FPO3Row = 1

Exit Function
exitNoGo:
  On Error GoTo 0
  Initilize_PublicVariables_Failed = True
End Function

Private Function ContinueRequested() As Boolean
'Function Set False at User's Request to stop
  ContinueRequested = True
   If MsgBox(Prompt:="Base mapping file: " & wbFPM.Name & vbCrLf _
       & "Daily Price Master file: " & wbDPM.Name & vbCrLf _
       & "Output file: " & FinalOutput & vbCrLf & vbCrLf & "Press 'OK' to continue?" & vbCrLf _
       & "press 'Ctlr + Break' to stop processing at any time", _
       Buttons:=vbOKCancel, _
       Title:="Price Mapping Tool" & Space(5) & "HC&TS, " & Format(Year(Date), "yyyy")) _
     <> vbOK Then ContinueRequested = False
End Function

Private Function Add_wbFPO_WorkSheets() As Boolean
'Function Set False on Error
  Add_wbFPO_WorkSheets = True
  On Error GoTo Failed
     If Application.SheetsInNewWorkbook < 3 Then wbFPO.Worksheets.Add Count:=(3 - Application.SheetsInNewWorkbook)
     Set wsFPO1 = wbFPO.Sheets(1)
     wsFPO1.Name = "Price records found"
        fillColumnHeaders wsFPO1
     Set wsFPO2 = wbFPO.Sheets(2)
     wsFPO2.Name = "No Price records found"
        fillColumnHeaders wsFPO2
     Set wsFPO3 = wbFPO.Sheets(3)
     wsFPO3.Name = "Multiple Price records found"
        fillColumnHeaders wsFPO3
      wbFPO.SaveAs Filename:=OFolder & FinalOutput, FileFormat:=51
Exit Function
Failed:
Add_wbFPO_WorkSheets = False
End Function

Private Sub PMPartI(FPMRow As Long)
' Part I: Price Information for System Upload where Price information is available
  FPO1Row = FPO1Row + 1
  
  wsFPO1.Cells(FPO1Row, "A").value = wsFPM.Cells(FPMRow, "C").value ' sku
  wsFPO1.Cells(FPO1Row, "B").value = "" ' ean
  wsFPO1.Cells(FPO1Row, "C").value = wsFPM.Cells(FPMRow, "D").value ' name
  wsFPO1.Cells(FPO1Row, "D").value = "" ' status
  wsFPO1.Cells(FPO1Row, "E").value = wsDPM.Cells(DPMRow, "C").value ' price
  wsFPO1.Cells(FPO1Row, "F").value = wsDPM.Cells(DPMRow, "E").value ' qty
  wsFPO1.Cells(FPO1Row, "G").value = "" ' specialrice
  If wsDPM.Cells(DPMRow, "D").value < wsDPM.Cells(DPMRow, "C").value Then _
    wsFPO1.Cells(FPO1Row, "G").value = wsDPM.Cells(DPMRow, "D").value ' specialrice
    'Guessing about IF Statement
  wsFPO1.Cells(FPO1Row, "H").value = "" ' specialate start
  wsFPO1.Cells(FPO1Row, "I").value = "" ' specialate end

End Sub

Private Sub PMPart2()
' Part II: populate all items from Sheet 1 where price information was not found in Sheet 2
     FPO2Row = FPO2Row + 1
     wsFPO2.Cells(FPO2Row, "A").value = wsDPM.Cells(DPMRow, "A").value ' sku
     wsFPO2.Cells(FPO2Row, "B").value = "" ' ean
     wsFPO2.Cells(FPO2Row, "C").value = wsDPM.Cells(DPMRow, "B").value ' name
     wsFPO2.Cells(FPO2Row, "D").value = "" ' status
     wsFPO2.Cells(FPO2Row, "E").value = wsDPM.Cells(DPMRow, "C").value ' price
     wsFPO2.Cells(FPO2Row, "F").value = wsDPM.Cells(DPMRow, "E").value ' qty
     wsFPO2.Cells(FPO2Row, "G").value = "" ' specialrice
     wsFPO2.Cells(FPO2Row, "H").value = "" ' specialate start
     wsFPO2.Cells(FPO2Row, "I").value = "" ' specialate end
End Sub

Private Function findAcronym(tVal As Variant) As String
  Dim rng As Range
  Set rng = Sheets("Merchants").Range("B:B").Find(What:=tVal, LookIn:=xlValues, LookAt:=xlWhole)
  If Not rng Is Nothing Then findAcronym = rng.Offset(0, -1).value
End Function

Private Function fillColumnHeaders(ws As Worksheet)
    Dim colNames As Variant
    Dim i As Long
    Dim x As Long
    colNames = Split("sku|ean|name|status|price|quantity|specialrice|specialate start|specialate end|", "|")
    With ws
        x = WorksheetFunction.Max(1, LBound(colNames))
        For i = LBound(colNames) To UBound(colNames)
            .Cells(1, x).value = colNames(i)
            x = x + 1
        Next i
    End With
End Function

Private Function timeElapsed(tStart As Date) As Double
    Dim tStop As Date
    Dim elapsed As Date
    tStop = Time
    If Hour(tStop) < Hour(tStart) Then
        elapsed = (TimeSerial(23, 59, 59) - tStart) + tStop
    Else
        elapsed = tStop - tStart
    End If
    Time elapsed = elapsed ' 86400
End Function

Private Function time2End(totalRows As Long, processedRows As Long, tStart As Date) As Double
    If Minute(tStart) = 0 Or processedRows = 0 Then Exit Function
    time2End = (totalRows * timeElapsed(tStart)) / processedRows
End Function