Develop a macro to solve below problem (1 Viewer)

Public FPMfolder AsString'* the foldername
Public FinalPM AsString'* the filename

'* value below will hold the values based upon the value in B4
Public DPMfolder AsString'* the foldername
Public DailyPM AsString'* the filename

Public OFolder AsString'* this will hold the foldername based upon the value in B5
Public FinalOutput AsString'* this will hold the actual outputfile name

Public wbTool As Workbook '* will be used to refer to the 'PriceMappingTool' file
Public wsTool As Worksheet '* refer to sheet named 'Main'

Public wbFPM As Workbook '* this will refer to the actual file named in B3
Public wsFPM As Worksheet '* the sheet of the above file where the data is to be found

Public wbDPM As Workbook '* this will refer to the actual file named in B4
Public wsDPM As Worksheet '* the sheet of the above file where the data is to be found

Public wbFPO As Workbook '* this will be used to refer to the file named on FinalOutput
Public wsFPO1 As Worksheet '* the sheet where the output data will be written to Sheet(1)
Public wsFPO2 As Worksheet '* the sheet where the output data will be written to Sheet(2)
Public wsFPO3 As Worksheet '* the sheet where the output data will be written to Sheet(3)

Public Merchant AsString'* if and when used to store the value of the selected Merchant's name
Public Acronym AsString'* if and when used to store the corresponding Acronym of the selected Merchant

Public ProcOK AsBoolean

Public FSPLIT AsVariant'* used to extract filename and foldername from variable
Public PressedState AsBoolean'* to trap Esc or Cancel button pressed

PublicSub MapAndConsolidate()
ProcOK =False: PressedState =False
Set wbTool = Workbooks("PriceMappingTool.xlsm")
Set wsTool = wbTool.Sheets("Main")
wbTool.Activate
If Len(Trim(wsTool.Range("B2")))=0Or Len(Trim(wsTool.Range("B3")))=0Or Len(Trim(wsTool.Range("B4")))=0Or Len(Trim(wsTool.Range("B5")))=0Then
MsgBox "Please verify THAT all the input values have been entered!", vbCritical,"OPERATION ABORTED !!!"
ExitSub
EndIf

Application.ScreenUpdating =False
'* below sets all the variables based upon the input values
FSPLIT = Split(wsTool.Range("B3").Value, Application.PathSeparator)
FinalPM = FSPLIT(CInt(UBound(FSPLIT)))
FPMfolder = Replace(wsTool.Range("B3").Value, FinalPM,"")
If Right(FPMfolder,1)<> Application.PathSeparator Then FPMfolder = FPMfolder & Application.PathSeparator

FSPLIT = Split(wsTool.Range("B4").Value, Application.PathSeparator)
DailyPM = FSPLIT(CInt(UBound(FSPLIT)))
DPMfolder = Replace(wsTool.Range("B4").Value, DailyPM,"")
If Right(DPMfolder,1)<> Application.PathSeparator Then DPMfolder = DPMfolder & Application.PathSeparator

OFolder = wsTool.Range("B5").Value
If Right(OFolder,1)<> Application.PathSeparator Then OFolder = OFolder & Application.PathSeparator

Merchant = wsTool.Range("B2").Value
Acronym = findAcronym(wsTool.Range("B2").Value)
If Len(Trim(Acronym))=0Then Acronym ="XXX"

OnErrorResumeNext
Set wbFPM = Workbooks(FinalPM)
If wbFPM IsNothingThenSet wbFPM = Workbooks.Open(Filename:=FPMfolder & FinalPM,ReadOnly:=True)
If wbFPM IsNothingThenGoTo exitNoGo

Set wbDPM = Workbooks(DailyPM)
If wbDPM IsNothingThenSet wbDPM = Workbooks.Open(Filename:=DPMfolder & DailyPM,ReadOnly:=True)
If wbDPM IsNothingThenGoTo exitNoGo

'Set wbFOP = Workbooks(FinalOutP)
'If wbFOP Is Nothing Then Set wbFOP = Workbooks.Open(Filename:=filePath & Application.PathSeparator & FinalOutP)
'If wbFOP Is Nothing Then GoTo exitNoGo

FinalOutput ="Final_Output-"& Format(Now(),"dd-mm-yyyy-HHmm")&"_"& Trim(Acronym)&".xlsx"

Err.Clear
OnErrorGoTo0

wbTool.Activate
Application.ScreenUpdating =True
If MsgBox("Base mapping file:"& vbCrLf & Chr(9)& wbFPM.Name & vbCrLf & _
"Daily Price Master file:"& vbCrLf & Chr(9)& wbDPM.Name & vbCrLf & _
"Output file:"& vbCrLf & Chr(9)& FinalOutput & vbCrLf & vbCrLf &"'OK' to continue?"& vbCrLf & vbCrLf & Chr(9)& _
"press 'Ctlr + Break' to stop processing at any time", vbOKCancel,"Price Mapping Tool"& Space(5)&"HC&TS, 2015")<> vbOK ThenGoTo exitSub

With Application
.ScreenUpdating =False
.EnableEvents =False
.Calculation = xlCalculationManual
.EnableCancelKey = xlDisabled
EndWith
Set wbFPO = Workbooks.Add
wbFPO.SaveAs Filename:=OFolder & FinalOutput, FileFormat:=51

'* the thre following rows adds the column headers to the three worksheets
fillColumnHeaders ws:=Sheets(1)
If wbFPO.Worksheets.Count =1Then wbFPO.Worksheets.Add
fillColumnHeaders ws:=Sheets(2)
If wbFPO.Worksheets.Count =2Then wbFPO.Worksheets.Add
fillColumnHeaders ws:=Sheets(3)

Set wsFPO1 = wbFPO.Sheets(1)
wsFPO1.Name ="Price records found"
Set wsFPO2 = wbFPO.Sheets(2)
wsFPO2.Name ="no Price records found"
Set wsFPO3 = wbFPO.Sheets(3)
wsFPO3.Name ="multiple Price records found"

wbFPO.Save
wbDPM.Activate

Dim tStart AsDate'* start timer
Dim tStop AsDate'* stop timer
Dim tEnd AsDate'* estimated end time
Dim tmidnite AsDate'* extra timer value if the process is started before and ends after midnight (next day)

tStart = Format(Now(),"hh:mm:ss")
tmidnite = Format(TimeValue("23:59:59"),"hh:mm:ss")


Dim FPMrng As Range '* range will refer to the data in the Final Product Mapping file
Dim DPMrng As Range '* range will refer to the data in the Daily Price Master file receiveed from Supplier
Dim lstFPMRow AsLong
Dim lstDPMRow AsLong
Dim FPMRow AsLong
Dim DPMRow AsLong
Dim FPO1Row AsLong
Dim FPO2Row AsLong
Dim FPO3Row AsLong

Set wsFPM = wbFPM.Sheets("Final Matched")
Set wsDPM = wbDPM.Sheets(1)

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
FPO1Row =1: FPO2Row =1: FPO3Row =1

OnErrorGoTo err_handler
Application.EnableCancelKey = xlErrorHandler
showProgressForm
For DPMRow =2To lstDPMRow
If DPMRow Mod50=0And lstDPMRow - DPMRow >50Then
tEnd = Format(time2End(lstDPMRow - DPMRow, DPMRow, tStart),"HH:mm:ss")
EndIf
Application.StatusBar ="PriceMapping Consolidation ... "& Format(DPMRow / lstDPMRow,"#0.0%")& IIf(DPMRow >=50, Space(5)&"estimated completion time remaining: "& tEnd,"")
If DPMRow >=50Then updateProgressMessage barMessage:="estimated completion time remaining: "& tEnd
updateProgessBarForm iCount:=DPMRow, iTotal:=lstDPMRow
With wsFPM.Range("A:A")
Set FPMrng =.Find(What:=(wsDPM.Cells(DPMRow,1).Value), LookIn:=xlValues, LookAt:=xlWhole)
IfNot FPMrng IsNothingThen
GoSub PMPartI
Else
GoSub PMPart2
EndIf
EndWith
If PressedState =TrueThen
SelectCase MsgBox("You have pressed 'Esc' or 'Cancel'!"& vbCrLf & vbCrLf & _
"Do you wish to stop the Price Mapping process?", vbExclamation + vbYesNo + vbDefaultButton2,"STOP PRICEMAPPING PROCESS?")
CaseIs= vbYes:ExitFor
CaseElse
PressedState =False
EndSelect
EndIf
Next DPMRow
Err.Clear
OnErrorGoTo0
uldpbf
wsFPO1.Cells.Columns.AutoFit
wsFPO2.Cells.Columns.AutoFit
wsFPO3.Cells.Columns.AutoFit
GoTo endRoutine

PMPartI:
'* Part I: Price Information for System Upload where Price information is available
FPMRow = FPMrng.Row
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
wsFPO1.Cells(FPO1Row,"H").Value =""'* specialate start
wsFPO1.Cells(FPO1Row,"I").Value =""'* specialate end
Return

PMPart2:
'* Part II: New worksheet to 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
Return

PMPart3:
'* Part III: New worksheet to populate all duplicate items from Sheet 1 where price information was not found in Sheet 2
FPO3Row =1
'* no code written for this
Return

err_handler:
If Err.Number =18Then PressedState =True
Err.Clear
Resume

endRoutine:
wbFPO.Save
tStop = Format(Now(),"hh:mm:ss")
ProcOK =True
GoTo exitSub

exitNoGo:
With Application
.ScreenUpdating =True
.EnableEvents =True
.Calculation = xlCalculationAutomatic
.EnableCancelKey = xlInterrupt
EndWith
Application.ScreenUpdating =True
MsgBox "One or more data files was not found or is not available!", vbExclamation,"OPERATION ABORTED"

exitSub:
Application.ScreenUpdating =True
Application.StatusBar =False
Err.Clear
OnErrorResumeNext
wbFPM.Close False
wbDPM.Close False
Set wbFPM =Nothing
Set wbDPM =Nothing
Set wbFPO =Nothing
Err.Clear
OnErrorGoTo0
SelectCase ProcOK
CaseIs=True
With wsTool
.Range("B2").ClearContents
.Range("B3").ClearContents
.Range("B4").ClearContents
.Range("B5").ClearContents
EndWith
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!"
CaseElse
MsgBox "Price Mapping not completed!", vbExclamation,"Price Mapping failed!"
EndSelect
wbTool.Save
EndSub

PublicFunction findAcronym(tVal AsVariant)AsString
Dim rng As Range
With Sheets("Merchants").Range("B:B")
Set rng =.Find(What:=tVal, LookIn:=xlValues, LookAt:=xlWhole)
IfNot rng IsNothingThen findAcronym = rng.Offset(0,-1).Value
EndWith
EndFunction

PublicFunction fillColumnHeaders(ws As Worksheet)
Dim colNames AsVariant
Dim i AsInteger
Dim x AsInteger
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
EndWith
EndFunction

PublicFunction timeElapsed(tStart AsDate)AsDouble
Dim tStop AsDate
Dim elapsed AsDate
tStop = Time
If Hour(tStop)< Hour(tStart)Then
elapsed =(TimeSerial(23,59,59)- tStart)+ tStop
Else
elapsed = tStop - tStart
EndIf
timeElapsed = elapsed '* 86400
EndFunction

PublicFunction time2End(totalRows AsLong, processedRows AsLong, tStart AsDate)AsDouble
If Minute(tStart)=0Or processedRows =0Then time2End =0:ExitFunction
time2End =(totalRows * timeElapsed(tStart))/ processedRows
EndFunction