- 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")))=0OrLen(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")<> vbOKThenGoTo 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 As
Date)AsDouble
If Minute(tStart)=0Or processedRows =0Then time2End =0:ExitFunction
time2End =(totalRows * timeElapsed(tStart))/ processedRows
EndFunction
<http://www.vbaexpress.com/forum/editpost.php?p=337764&do=editpost>
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at https://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
