Loading... #### 变量声明区 ```VBA Sub newProductPPA() Dim wb, wbPPA As Workbook Dim ws, wsPPA As Worksheet Dim strArray() As String Dim intArray1() As Long Dim intArray2() As Integer Dim itm, str, clm, off Dim a, b As Integer Dim varStr As String Dim aaa As Variant Dim segment, dt, plant, MKPname, PJMname, projectName, productName As String Dim cnt, module, frstrow, forecast, eSOL, cntYes, cntTBC As Long Dim Rng, rng2, targetRng, ppaRange As Range Dim eHubE, eHubI, mHub As Range Dim SOLforcast As Date ``` #### 解锁文件和确认导入 ```VBA Set wb = ActiveWorkbook Set ws = wb.Worksheets("Launch tracking tool") If ws.ProtectContents = True Then ws.Unprotect Password: b = "Lmd1213" On Error GoTo cleanup Set wsPPA = Application.InputBox("Select a cell on the PPA sheet.", Type:=8, title:="PPA Input.").Parent Set wbPPA = wsPPA.Parent Err.Clear On Error GoTo 0 'On Error GoTo cleanup 'making sure events and screenupdating are enabled in case of error ``` 输入端选中了PPA文档，以定位要输入的PPA文件。 ```VBA ws.Activate feedback = MsgBox("Please make sure that in the selected PPA all countries with Launch Decision status Yes have SOL date. Continue?", vbOKCancel) If feedback = 2 Then MsgBox ("Import has been aborted") Cancel = True Exit Sub End If cnt = 1 eSOL = 1000 cntYes = 0 cntTBC = 0 ``` --- #### 获取PPA的基本信息 ```VBA With wsPPA 'getting basic information from named PPA ranges segment = .Range("PuT").Value dt = .Range("lead_region").Value plant = .Range("plnt").Value MKPname = .Range("MKP").Value PJMname = .Range("PJM").Value projectName = .Range("ProjectName").Value module = .Range("cnt").Value End With ``` 注意，Range是命名的，可以通过公式-名称管理器来获得目前的名称和对应位置。   #### 确定有多少个Execution ```VBA While cnt <= module 'defines how may modules are imported productName = wsPPA.Range("ModuleName" & cnt).Value Application.EnableEvents = False frstrow = InsertNewProduct(segment, productName, projectName, dt, plant, MKPname, PJMname) 'calls macro for format build up， 这一部分已经format做完了。frstrow应该只是一个返回的空值或者0 因为InsertNewProduct没有设定返回值 ws.Activate ``` 注意，cnt在PPA表中用来定义exection的数量，其实是一个空的cell，让PM填入的，这里只是用来做确认execution数量使用。 #### 导入多个execution和region的PPA数字 ```VBA With ws 'circulates all named PPA ranges for all modules and regions, SKU Launch decision and SOL date are imported For Each str In Array("RAF", "RAP", "EEMIDE", "RLA") '列举数组 For Each clm In Array(15, 48, 49, 58, 59) '列举第二个数组 If str = "RAF" Then forecast = 0 a = 1 '更新行数开始定位，下同 b = 4 '更新行数结束定位，下同 ElseIf str = "RAP" Then forecast = 5 a = 6 b = 15 ElseIf str = "EEMIDE" Then forecast = 16 a = 17 b = 23 ElseIf str = "RLA" Then forecast = 24 a = 25 b = 36 End If If clm = 15 Then varStr = "LD" ElseIf clm = 48 Then varStr = "SOL" ElseIf clm = 49 Then varStr = "Deli" ElseIf clm = 58 Then varStr = "SKU" ' SKU range name ?? ElseIf clm = 59 Then varStr = "PREDECESSORSKU" ' Predecessor SKU range name ?? End If ``` 注意：vastr是一个string。 #### 执行循环的目标range ``` Set targetRng = ws.Range(Cells(frstrow + a, clm), Cells(frstrow + b, clm)) If str = "EEMIDE" Then 'ranges can be found on PPA "settings" sheet Set ppaRange = wbPPA.Sheets("Settings").Range(str & varStr & cnt) ElseIf str = "RAF" Then 'ranges can be found on PPA "settings" sheet Set ppaRange = wbPPA.Sheets("Settings").Range(str & varStr & cnt) Else Set ppaRange = wsPPA.Range(str & varStr & cnt) ' Sets the range of the SKU or SOL or LD or DELI ????? End If ``` - [ ] 这里有一个问题，为何没有AP或LA?但执行出的结果是都有的？ ```VBA If clm = 15 Then 'defining MKP forecast launc decision ys if a yes is found tbc if no yes but one tbc can be found For Each Rng In ppaRange If Rng.Value = "Yes" Then cntYes = cntYes + 1 ElseIf Rng.Value = "TBC" Then cntTBC = cntTBC + 1 End If Next Rng If cntYes >= 1 And cntTBC = 0 Or cntYes >= 1 And cntTBC >= 1 Then Cells(frstrow + forecast, 15).Value = "Yes" ElseIf cntYes = 0 And cntTBC >= 1 Then Cells(frstrow + forecast, 15).Value = "TBC" ElseIf cntYes = 0 And cntTBC = 0 Then Cells(frstrow + forecast, 15).Value = "Done" End If cntYes = 0 cntTBC = 0 Call TriggerUpdate(Cells(frstrow + forecast, 15)) End If ``` 以上是Launch Decision的输入，可见列数位置为15，Triggerupdate主要是根据该行的Launch Decision变更LTT后续格子的格式 ```VBA If clm = 48 Then If str = "EEMIDE" Then For Each Rng In ppaRange If Rng.Offset(0, -1) = "Yes" Then 'finding the earlies SOL date for MKP forecast on settings sheet If DateDiff("d", DateValue(Date), DateValue(Rng)) < eSOL Then SOLforcast = DateValue(Rng) eSOL = DateDiff("d", DateValue(Date), DateValue(SOLforcast)) End If End If 'End If Next Rng eSOL = 1000 ElseIf str = "RAF" Then For Each Rng In ppaRange If Rng.Offset(0, -1) = "Yes" Then 'finding the earlies SOL date for MKP forecast on settings sheet If DateDiff("d", DateValue(Date), DateValue(Rng)) < eSOL Then SOLforcast = DateValue(Rng) eSOL = DateDiff("d", DateValue(Date), DateValue(SOLforcast)) End If End If 'End If Next Rng eSOL = 1000 'eSOL只是为了保障当具体日期相差超过1000天的时候，不加入LTT Else For Each Rng In ppaRange If wsPPA.Cells(Rng.row, 24) = "Yes" Then 'finding the earlies SOL date for MKP forecast If DateDiff("d", DateValue(Date), DateValue(Rng)) < eSOL Then SOLforcast = DateValue(Rng) eSOL = DateDiff("d", DateValue(Date), DateValue(SOLforcast)) End If End If ' End If Next Rng eSOL = 1000 End If ``` #### 根据Yes的Launch Decision添加SoL日期和格式刷 ```VBA End If If .Cells(frstrow + forecast, 15).Value = "Yes" Then .Cells(frstrow + forecast, 48).Value = DateValue(SOLforcast) Call TriggerUpdate(Cells(frstrow + forecast, 48)) 'triggers correct event for colors, task dates etc End If End If targetRng.Value = ppaRange.Value 'paste in ranges including sku number and such For Each Rng In targetRng Call TriggerUpdate(Rng) 'triggers correct event for colors, task dates etc possible area for the SKU setting location If clm = 48 And Cells(Rng.row, 15) <> "Yes" Then Cells(Rng.row, 48).ClearContents Next Rng Next clm Next str End With cnt = cnt + 1 Wend ``` #### 程序结尾 ```VBA Application.EnableEvents = True Application.ScreenUpdating = True 'Sheets("Launch tracking tool").Protect Password:="Lmd1213", UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, DrawingObjects:=False 'Sheets("Launch tracking tool").EnableOutlining = True MsgBox "The new product has been succesfully added!", title:="Insertion is done." Exit Sub cleanup: 'in the case of an error make sure the workbook is workable and protected 'Sheets("Launch tracking tool").Protect Password:="Lmd1213", UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, DrawingObjects:=False 'Sheets("Launch tracking tool").EnableOutlining = True Application.EnableEvents = True Application.ScreenUpdating = True MsgBox "Oops, something went wrong.", title:="ERROR" End Sub ``` 最后修改：2022 年 08 月 30 日 © 允许规范转载 赞 如果觉得我的文章对你有用，请随意赞赏