PDA

View Full Version : Develop a macro to solve below problem



saurabh12222
02-04-2016, 03:34 AM
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

GTO
02-04-2016, 03:56 AM
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:


'Your VBA code goes here

Mark

SamT
02-04-2016, 03:18 PM
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?

saurabh12222
02-04-2016, 10:08 PM
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

SamT
02-04-2016, 10:26 PM
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
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

Sample VBAToHTML Paste inside CODE Tags

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
Sample Direct Copy and Paste inside CODE Tags

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

saurabh12222
02-04-2016, 10:36 PM
SamT - Thankyou for your update .

saurabh12222
02-04-2016, 10:39 PM
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

saurabh12222
02-04-2016, 10:40 PM
IS THIS BETTER NOW ..

SamT
02-05-2016, 09:16 AM
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.

Aussiebear
02-05-2016, 03:29 PM
I have edited your code as best I can, but there may be some errors still contained within


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

Aussiebear
02-07-2016, 11:37 PM
Have I done this for nothing?

SamT
02-08-2016, 09:31 AM
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

SamT
02-08-2016, 02:47 PM
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

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

Aussiebear
02-09-2016, 10:35 PM
Thanks for that Sam. I note though that the OP has not returned....