Develop a macro to solve below problem

• Here is the problem
  
  
  Sheet 1 - file 1 is base datafile thats maps our master product file with master product file received from our suppliers / merchants listing supplier product code to our product code, and supplier name to our name. This is prepared basis a one time exercise.
• Sheet 1 - file 2 is daily price list that we receive from the supplier in that format - it lists down supplier product code, supplier product name, MRP i.e. list price, selling price - at times this is at a discount to list price, and quantity available for sale.
• Sheet 1 - file 3 is the format in which we need output basis mapping of sheet 1 with sheet 2. Instructions are given against each field. We use file 3 to upload the file in our system that calculates final selling price to retail consumers. Our agents often refer this final file while discussing sales with potential customers.
  
  
  Here is the code . Please let me know what is the problem in the code . Not able to get it .

• 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 =""'* special:price
  If wsDPM.Cells(DPMRow,"D").Value < wsDPM.Cells(DPMRow,"C").Value Then _
  wsFPO1.Cells(FPO1Row,"G").Value = wsDPM.Cells(DPMRow,"D").Value '* special:price
  wsFPO1.Cells(FPO1Row,"H").Value =""'* special:Date start
  wsFPO1.Cells(FPO1Row,"I").Value =""'* special:Date 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 =""'* special:price
  wsFPO2.Cells(FPO2Row,"H").Value =""'* special:Date start
  wsFPO2.Cells(FPO2Row,"I").Value =""'* special:Date 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|special:price|special:Date start|special:Date 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
  

Hi there,

It might be helpful for anyone trying to read your code if you would edit your first post and use code tags around the VB code. Like:

[CODE]'Your VBA code goes here[/CODE]

Mark

When pasting code into a VBAX post, copy the code from your Excel VBA editor. Do not use any other editor which may use some formatting codes.

What is the problem?

What is happening AND what is not supposed to happen?

SamT - I Have pasted it from VBA editor only hence the alignment and the text color . The problem is the output sheet is not proper . The output file should have three sheets . First sheet containing the mapped items , second sheet showing items whose list price information is not available and third sheet showing that multiple Price records found

Quote:

---

I Have pasted it from VBA editor only hence the alignment and the text color

---

I am sorry, but that is not the case. There are no [BB] formatting codes used in any Microsoft VBA editor that can be copied and pasted into the VBA Express dot com post Editor.

You may be using the VBAToHTML Addin to copy the code.

You should just select the code and Copy it direct. Either with a Right Click or by pressing Ctrl+C

Sample VBAToHTML Paste
[face=Courier New]Sub SetZoom()
Dim n, s As Worksheet
Set s = ActiveSheet
With ActiveWorkbook
For Each n In Worksheets
n.Activate
ActiveWindow.Zoom = 75
Next n
End With
s.Activate

End Sub[/face]

Sample VBAToHTML Paste inside CODE Tags

Code:

---

[face=Courier New]Sub SetZoom()
Dim n, s As Worksheet
Set s = ActiveSheet
With ActiveWorkbook
    For Each n In Worksheets
      n.Activate
        ActiveWindow.Zoom = 75
    Next n
End With
s.Activate
   
End Sub[/face]

---

Sample Direct Copy and Paste inside CODE Tags

Code:

---

Sub SetZoom()
Dim n, s As Worksheet
Set s = ActiveSheet
With ActiveWorkbook
    For Each n In Worksheets
      n.Activate
        ActiveWindow.Zoom = 75
    Next n
End With
s.Activate
   
End Sub

---

SamT - Thankyou for your update .

Code:

---

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

---

IS THIS BETTER NOW ..

Yes it is, Thank you.

When Mark007 wrote the PHP routine that formats the text between CODE Tags he included an auto-indent function. If you look at the code you just posted you will notice that the indents are stair stepping. This is due to many words without spaces betweenthem. I am not sure if this is a side effect of the Copy Paste and the Editor, or if it is reflective of your code. I noticed the same thing in, IIRC, the same places in your first post.

Other than that, your code looks very well structured and thought out. If the typos are actually in your code these suggestions will help:

In the VBA Editor, click on the Tools menu Options. On the Editor tab, put a check mark in every box in the Code Settings Frame. OK the Options dialog and at the top of all your existing code pages put the words "Option Explicit." The Require Variable Declarations Option you checked will add this to any new pages created.

In the VBA editor, Ctrl+H will bring up the Find And Replace Dialog. I suggest that you first Find and Replace the following

• "End" with "End " (End + space)
• "Then" with " Then" (space + Then)
• "Next" with "Next " (Next + space)

That should fix %99 of the typos I see in your posted code.

Another troubleshooting technique VBA has is Compile on Demand. The menu item "Debug" has the Compile Command. The Compiler will stop when it notices an error and Highlight the line it stopped at. If you can't see an error in the highlighted line, look at all the code before the line.

Another technique I have used is Mark007's auto-indent. :) In the VBA Express Testing Forum, start a new thread. Use the "Go Advanced" button to open the Advanced Editor which has a Preview button. Paste your code with CODE Tags and Preview the results. If you see stair stepping indentation, you will have a very good clue as to where you missed an End or Loop Statement.

I have edited your code as best I can, but there may be some errors still contained within

Code:

---

Public FPMfolder As String ' the foldername
Public FinalPM As String ' the filename
' value below will hold the values based upon the value in B4
Public DPMfolder As String  ' the foldername
Public DailyPM As String  ' the filename
Public OFolder As String  ' this will hold the foldername based upon the value in B5
Public FinalOutput As String  ' 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 As String  ' if and when used to store the value of the selected Merchant's name
Public Acronym As String  ' if and when used to store the corresponding Acronym of the selected Merchant
Public ProcOK As Boolean
Public FSPLIT As Variant  ' used to extract filename and foldername from variable
Public PressedState As Boolean  ' to trap Esc or Cancel button pressed
 
 
Public Sub MapAndConsolidate()
ProcOK =False: PressedState =False
Set wbTool = Workbooks("PriceMappingTool.xlsm")
Set wsTool = wbTool.Sheets("Main")
wbTool.Activate
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 Sub
End If
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 '<---Where is the end If for this if?
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 '<----Where is the end If for this if?
OFolder = wsTool.Range("B5").Value
    If Right(OFolder,1)<> Application.PathSeparator Then OFolder = OFolder & Application.PathSeparator '<---Where is the end If for this If?
Merchant = wsTool.Range("B2").Value
    Acronym = findAcronym(wsTool.Range("B2").Value)
    If Len(Trim(Acronym))=0 Then Acronym ="XXX" '<---Where is the end if for this If?
On Error Resume Next
Set wbFPM = Workbooks(FinalPM)
If wbFPM Is Nothing Then '<---Where is the End If for this if??
Set wbFPM = Workbooks.Open(Filename:=FPMfolder & FinalPM,ReadOnly:=True)
If wbFPM Is Nothing Then Go To exit NoGo ' <--- Where is the end if for this if?
Set wbDPM = Workbooks(DailyPM)
If wbDPM Is Nothing Then '<--- Where is the end if for this if?
Set wbDPM = Workbooks.Open(Filename:=DPMfolder & DailyPM,ReadOnly:=True)
If wbDPM Is Nothing Then Go To exit NoGo '<---Where is the end if for this if?
'<--- the next three lines you have commented out, but check the If's requirements here as well
'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
On Error Go To 0
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 Then
Go To exit Sub
With Application
        .ScreenUpdating =False
        .EnableEvents =False
        .Calculation = xlCalculationManual
        .EnableCancelKey = xlDisabled
        End With
        Set wbFPO = Workbooks.Add
        wbFPO.SaveAs Filename:=OFolder & FinalOutput, FileFormat:=51
' the three following rows adds the column headers to the three worksheets
fill ColumnHeaders ws:=Sheets(1)
If wbFPO.Worksheets.Count =1 Then wbFPO.Worksheets.Add '<--- Where is the end if for this if?
fill ColumnHeaders ws:=Sheets(2)
If wbFPO.Worksheets.Count =2 Then wbFPO.Worksheets.Add '<--- Where is the end if for this if?
fill ColumnHeaders 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 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)
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 As Long
Dim lstDPMRow As Long
Dim FPMRow As Long
Dim DPMRow As Long
Dim FPO1Row As Long
Dim FPO2Row As Long
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
On Error Go To err_handler
Application.EnableCancelKey = xlErrorHandler
show ProgressForm
For DPMRow =2 To lstDPMRow
If DPMRow Mod50=0 And lstDPMRow - DPMRow >50 Then
tEnd = Format(time2End(lstDPMRow - DPMRow, DPMRow, tStart),"HH:mm:ss")
End If
Application.StatusBar ="PriceMapping Consolidation ... "& Format(DPMRow / lstDPMRow,"#0.0%")& IIf(DPMRow >=50, Space(5) &"estimated completion time remaining: "& tEnd,"")
If DPMRow >=50 Then '<--- Where is the end if for this if?
update ProgressMessage barMessage:="estimated completion time remaining: "& tEnd
update ProgessBarForm iCount:=DPMRow, iTotal:=lstDPMRow
With wsFPM.Range("A:A")
Set FPMrng =.Find(What:=(wsDPM.Cells(DPMRow,1).Value), LookIn:=xlValues, LookAt:=xlWhole)
If Not FPMrng Is Nothing Then
Go Sub PMPartI
Else
Go Sub PMPart2
End If
End With
If Pressed State =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
Err.Clear
On Error Go To 0
uldpbf  ' <---what does this mean???
wsFPO1.Cells.Columns.AutoFit
wsFPO2.Cells.Columns.AutoFit
wsFPO3.Cells.Columns.AutoFit
Go To end Routine
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 _  '<--- Where is the end if for this if?
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 =18 Then Pressed State =True '<--- Where is the end if for this if
Err.Clear
Resume
end Routine:
wbFPO.Save
tStop = Format(Now(),"hh:mm:ss")
ProcOK =True
Go To exit Sub
exit NoGo:
With Application
.ScreenUpdating =True
.EnableEvents =True
.Calculation = xlCalculationAutomatic
.EnableCancelKey = xlInterrupt
End With
Application.ScreenUpdating =True
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
Err.Clear
On Error Go To 0
Select Case ProcOK
Case Is=True
With wsTool
.Range("B2").ClearContents
.Range("B3").ClearContents
.Range("B4").ClearContents
.Range("B5").ClearContents
End With
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!"
Case Else
MsgBox "Price Mapping not completed!", vbExclamation,"Price Mapping failed!"
End Select
wbTool.Save
End Sub
                               
Public Function findAcronym(tVal AsVariant)AsString
Dim rng As Range
With Sheets("Merchants").Range("B:B")
Set rng =.Find(What:=tVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then '<---Where is the end if for this if?
findAcronym = rng.Offset(0,-1).Value
End With
End Function
                                   
Public Function fillColumnHeaders(ws As Worksheet)
Dim colNames As Variant
Dim i As Integer
Dim x As Integer
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
                                       
Public Function timeElapsed(tStart AsDate)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
                                           
Public Function time2End(totalRows AsLong, processedRows AsLong, tStart AsDate) As Double
If Minute(tStart)=0 Or processedRows =0 Then time2End =0 '<---Where is the end if for this if?
:Exit Function
time2End =(totalRows * timeElapsed(tStart))/ processedRows
End Function

---

Have I done this for nothing?

Wasn't for nothing, you got rid of all those stairs :D

I wonder where the OP got that pretty advanced code?

BTW, there were some proper one-liner IFs in there
If Something Then Goto

I looked the code over after you got done with it.

It is my opinion that this code has been deliberately broken.
That Someone deliberately entered errors in logic.
That Someone replaced Calls with Comments.
That Someone methodically added many spaces between multi "word" variables and statements and deleted many spaces between two words.

Examples:
GoTo LineLabel became Go To Line Label
As VarType became AsVarType
End If became EndIF

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 :dunno

Attachment 15367

Module Level Declarations

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Code:

---

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

---

Thanks for that Sam. I note though that the OP has not returned....