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
Reply With Quote
