Develop a macro to solve below problem

[saurabh12222]

• 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 =""'* 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