· 6 years ago · Aug 03, 2019, 12:06 AM
1Option Explicit
2
3Sub Master()
4
5 Dim lastCol As Long
6 Dim lastRow As Long
7 Dim wsGPL As Worksheet
8 Dim wbGPL As Workbook
9
10 'If MsgBox("This is a demanding macro. Please be sure to save any other work to avoid losing it. This will take about 5 minutes. Ready to start?", vbYesNo) = vbNo Then Exit Sub
11
12 Application.ScreenUpdating = False
13
14 'Variable for main worksheet
15 Set wsGPL = Sheets("Group_PositionList")
16
17 'These are used in a few places, might as well carry it through subs that update the table
18 lastRow = wsGPL.Cells(Rows.Count, 1).End(xlUp).Row
19 lastCol = wsGPL.Cells(1, Columns.Count).End(xlToLeft).Column
20
21 '\\//CAO Processes
22 Call RemoveDashOnes(lastRow)
23 Call CAO_Report(lastRow, lastCol)
24 Call CAO_Breakout(lastRow)
25 Call CAO_Clean
26 '//\\
27
28 'Delete Max Facings Column
29 wsGPL.Range("K1").EntireColumn.Delete
30 lastCol = lastCol - 1
31
32 'Convert all movements & counts to numbers
33
34 wsGPL.Range(wsGPL.Cells(2, 5), wsGPL.Cells(lastRow, lastCol)).NumberFormat = "0"
35
36 'Get Estimated Reset Inventory, this tells the inventory for the additional stores carrying each item.
37 'Change all POG UPC counts to 1
38 Call GetERI(wsGPL)
39
40 'GetERI added columns, recalc
41 lastCol = wsGPL.Cells(1, Columns.Count).End(xlToLeft).Column
42
43 'Build Additional Stores Using Item Sheet
44 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Addtnl Strs Per Item"
45
46 '=====Copy the data=====
47 Range("A1:F" & lastRow).Value = wsGPL.Range("A1:F" & lastRow).Value
48 Range(Cells(1, 7), Cells(lastRow, lastCol - 3)).Value = wsGPL.Range(wsGPL.Cells(1, 10), wsGPL.Cells(lastRow, lastCol)).Value
49
50 lastCol = lastCol - 3
51 Range(Cells(1, lastCol), Cells(lastRow, lastCol)).EntireColumn.Interior.Color = RGB(200, 200, 200)
52
53 ActiveSheet.Cells.EntireColumn.AutoFit
54
55
56 '=====Run Input Macros=====
57
58 'Serves no purpose currently...
59 'Call Input_PoG_Usage
60
61 'Run BuyerWarehouse
62 Call BuyerWarehouse(wsGPL, lastCol, lastRow)
63
64 'Run Calculate
65 'Call Calculate
66
67 '=====Formatting=====
68
69 'Color Rows based on Max Position Count
70 With Range("A2:G" & lastRow)
71 .FormatConditions.Add Type:=xlExpression, Formula1:="=$G2=0"
72 .FormatConditions(1).Interior.Color = 6908415
73 End With
74
75 'Hide Group_PositionList Sheet
76 'wsGPL.Visible = False
77
78 'Freeze Top Row, Rename Headers, & AutoFit Columns
79 With ActiveWindow
80 .SplitColumn = 0
81 .SplitRow = 1
82 End With
83 ActiveWindow.FreezePanes = True
84
85 Range("A1").Value = "Order #"
86 Range("B1").Value = "UPC"
87 Range("E1").Value = "Current Store Count"
88 Range("F1").Value = "Mvmnt"
89 Cells.EntireColumn.AutoFit
90
91 'Add Title & Reset Date
92 Rows("1:1").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
93 Range("A1").Value = Application.InputBox("Buyer Report Title?")
94 With Cells(2, lastCol)
95 .Offset(-1, -2).Value = "Reset Date: "
96 .Offset(-1, -2).HorizontalAlignment = xlRight
97 .Offset(-1, -1).Value = Application.InputBox("Reset Date?")
98 .Offset(-1, -1).HorizontalAlignment = xlLeft
99 End With
100 Set wbGPL = ActiveWorkbook
101 'CAO Relocate
102 Call CAO_Relocate_New
103
104 'Add Estimated Reset Inventory and multiply by Change in store count.
105 wsGPL.Activate
106 ActiveSheet.Range("A1").Select
107 Selection.End(xlToRight).Select
108 Selection.Offset(, -1).Select
109 Range(Selection, Selection.End(xlDown)).Select
110 Selection.Offset(, 1).Select
111 Selection.Copy
112
113 'Activate the destination worksheet
114 Sheets("Addtnl Strs Per Item").Activate
115 'Select the target range
116 With ActiveSheet
117 Range("A2").End(xlToRight).Select
118 ActiveCell.Offset(, 1).Select
119 End With
120 'Paste in the target destination
121 ActiveSheet.Paste
122 Application.CutCopyMode = False
123 With ActiveSheet
124 .Cells.EntireColumn.AutoFit
125 .Range("A:A").ColumnWidth = 9.6
126 End With
127 'Multiply by change in store count
128 Dim e As Long, f As Long, chng As Long
129
130 With Sheets("Addtnl Strs Per Item")
131 lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
132 lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
133 chng = .Cells(3, lastCol - 3).Column
134
135 For e = 3 To lastRow
136 For f = lastCol To lastCol
137 If Cells(e, lastCol).Value > 0 Then
138 Cells(e, lastCol).Value = .Cells(e, lastCol).Value * Cells(e, chng).Value
139 End If
140 Next
141 Next e
142 .Cells(1, lastCol).ColumnWidth = 11.25
143 .Range(Cells(2, lastCol), Cells(lastRow, lastCol)).Interior.ColorIndex = 43
144 .Range(Cells(2, lastCol), Cells(lastRow, lastCol)).EntireColumn.NumberFormat = "0"
145 .Cells(2, lastCol).Value = "Est Reset Inv"
146
147 For e = 3 To lastRow
148 If Round(Cells(e, lastCol)) < .Cells(e, chng) Then
149 .Cells(e, chng).Interior.ColorIndex = 43
150 .Cells(e, lastCol).Interior.ColorIndex = 46
151 End If
152 Next e
153 End With
154
155 'Hide POG Columns
156 Range("H1").Select
157 Range(Selection, Selection.End(xlToRight)).Select
158 Selection.EntireColumn.Hidden = True
159 Range("A2").End(xlToRight).Select
160 Selection.Offset(, -3).EntireColumn.Hidden = False
161
162
163 'Buyer Name Lookup
164 Range("A2").End(xlToRight).Select
165 Selection.Offset(, 1).Select
166 Selection.Value = "Buyer Name"
167
168 Selection.Offset(1, 0).Activate
169 ActiveCell.FormulaR1C1 = _
170 "=IF(RC[-2]>1,VLOOKUP(RC[-2],'[Buyer Report Generator V5.xlsm]Buyer_Report_Generator'!R2C1:R38C2,2,FALSE),"""")"
171
172 lastRow = Range("B2").End(xlDown).Row
173 ActiveCell.AutoFill Range(ActiveCell.Address, Cells(lastRow, ActiveCell.Column))
174
175
176 'Paste Values
177 Range("A2").Select
178 Selection.End(xlToRight).Select
179 Selection.EntireColumn.Copy
180
181 Range("A2").End(xlToRight).Select
182 Selection.Offset(-1, 0).Select
183
184 Selection.PasteSpecial Paste:=xlPasteValues
185 Application.CutCopyMode = False
186
187 'Final AutoFit & add filters
188 ActiveSheet.Range("A2").End(xlToRight).Select
189 Selection.EntireColumn.AutoFit
190 ActiveSheet.Range("A2").AutoFilter
191 ActiveSheet.Range("A1").Select
192
193 Workbooks("Buyer Report Generator V5.xlsm").Close False
194 wbGPL.Sheets("Addtnl Strs Per Item").Activate
195 MsgBox "Macro Complete"
196
197End Sub
198Sub RemoveDashOnes(ByRef lastRow As Long)
199 Dim i As Long
200
201 For i = lastRow To 2 Step -1
202 If Right(Cells(i, 2).Value, 2) = "-1" Then
203 Cells(i, 2).EntireRow.Delete shift:=xlUp
204 lastRow = lastRow - 1
205 End If
206 Next
207
208End Sub
209Sub CAO_Report(ByVal lastRow As Long, ByVal lastCol As Long)
210 'Dim lastCol as long 'Since these are copies you can just take the lastrow and lastCol from the other place
211 'Dim lastRow as long
212 Dim i As Long
213 Dim rng As Range
214 Dim strReplace As String
215 Dim strStoreNumber As String
216 Dim arrP_ID() As Variant
217
218 'Create new copies of report for later extraction
219 ActiveSheet.Copy After:=Worksheets(Sheets.Count)
220 ActiveSheet.Name = "Distribution"
221 ActiveSheet.Copy After:=Worksheets(Sheets.Count)
222 ActiveSheet.Name = "CAO Report"
223 Range("A:A").EntireColumn.Delete '1 column deleted
224 Range("B:J").EntireColumn.Delete '9 columns deleted
225
226 lastCol = lastCol - 10 '1 + 9 = 10
227
228 'Format new tab and strip down to needed data
229 Set rng = Range("A2:A" & lastRow)
230
231
232 'Format ye olde product IDs
233 arrP_ID = rng
234 For i = LBound(arrP_ID, 1) To UBound(arrP_ID, 1)
235 arrP_ID(i, 1) = Left(CStr(arrP_ID(i, 1)), Len(arrP_ID(i, 1)) - 1)
236 Next i
237 rng = arrP_ID
238 rng.NumberFormat = "0000000000000"
239 rng.ColumnWidth = 14
240
241 'Pull store numbers from POG names
242 For i = 2 To lastCol
243 strStoreNumber = Cells(1, i).Value
244 strReplace = Mid(strStoreNumber, Len(strStoreNumber) - 6, 3)
245 Cells(1, i).Value = strReplace
246 Next i
247
248 Set rng = Nothing
249 Erase arrP_ID
250
251End Sub
252Sub CAO_Breakout(ByVal lastRow As Long)
253
254 Dim rP_ID As Range
255 Dim i As Long
256 Dim lastCol As Long
257 Dim strStore As String
258 Dim wsCAO As Worksheet
259 Dim wsDuplicate As Worksheet
260
261 Set wsCAO = ActiveWorkbook.Worksheets("CAO Report")
262 lastCol = wsCAO.Cells(1, Columns.Count).End(xlToLeft).Column
263 Set rP_ID = wsCAO.Range("A1:A" & lastRow)
264
265 'Looper makes new tab for store, if it already exists, go to "ExistingStrNum"
266 On Error GoTo ExistingStrNum
267
268 For i = lastCol To 2 Step -1
269 Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsCAO.Cells(1, i).Value
270 Range("A1:A" & lastRow).Value = rP_ID.Value
271 Range("A1").ColumnWidth = 14
272 Range("A2:A" & lastRow).NumberFormat = "0000000000000"
273 Range("B1:B" & lastRow).Value = wsCAO.Range(wsCAO.Cells(1, i), wsCAO.Cells(lastRow, i)).Value
274
275Looper:
276 Next i
277
278DeleteAndExit:
279 '\\//When loop finishes, delete empty CAO report sheet and exit
280 Application.DisplayAlerts = False
281 wsCAO.Delete
282 Application.DisplayAlerts = True
283
284 Set rP_ID = Nothing
285 Set wsCAO = Nothing
286 Set wsDuplicate = Nothing
287
288 Exit Sub
289
290 'Add duplicate store number data to existing tab
291ExistingStrNum:
292 Application.DisplayAlerts = False
293 ActiveSheet.Delete
294 Application.DisplayAlerts = True
295
296 strStore = CStr(wsCAO.Cells(1, i))
297
298 If strStore <> "" Then
299 Set wsDuplicate = Sheets(strStore)
300 'wsDuplicate.Activate
301 Else
302 GoTo DeleteAndExit
303 End If
304
305 'When you find a duplicate, add it to the existing totals
306 Call SumDuplicateStoreData(wsDuplicate.Range(wsDuplicate.Cells(2, 2), wsDuplicate.Cells(lastRow, 2)), wsCAO.Range("B2:B" & lastRow))
307
308 Resume Looper
309
310End Sub
311'Add existing data and duplicate store data together, write in duplicate worksheet
312Private Sub SumDuplicateStoreData(ByRef rngDest As Range, ByRef rngCAO As Range)
313 Dim arrTotal() As Variant
314 Dim arrDuplicate() As Variant
315 Dim i As Long
316
317 arrTotal = rngDest.Value 'Existing data
318 arrDuplicate = rngCAO.Value 'New data
319
320 'Should put a check to make sure it's an array
321
322 For i = LBound(arrTotal, 1) To UBound(arrTotal, 1)
323
324 'If existing data is blank, but new data has a number value, overwrite
325 If arrTotal(i, 1) = Empty And arrDuplicate(i, 1) <> Empty Then
326 arrTotal(i, 1) = arrDuplicate(i, 1)
327
328 'If new data and existing data have number values, add them together
329 ElseIf IsNumeric(arrDuplicate(i, 1)) And IsNumeric(arrTotal(i, 1)) Then
330 arrTotal(i, 1) = arrTotal(i, 1) + arrDuplicate(i, 1)
331
332 'Otherwise, set data to 0
333 Else
334 arrTotal(i, 1) = 0
335 End If
336
337 Next i
338
339 'Write summed values back to sheet
340 rngDest.Value = arrTotal
341
342 Erase arrTotal
343 Erase arrDuplicate
344
345End Sub
346Sub CAO_Clean()
347
348 Dim sht As Worksheet
349 Dim rngTemp As Range
350
351 For Each sht In ActiveWorkbook.Worksheets
352 Select Case sht.Name
353 Case "Group_PositionList", "Distribution"
354 'do nothing
355 Case Else
356 'Filter for zero values
357 sht.UsedRange.AutoFilter field:=1, Criteria1:="<>"
358 sht.UsedRange.AutoFilter field:=2, Criteria1:="0", Operator:=xlOr, Criteria2:=""
359 'Offset needed to spare the headers, I think
360 Set rngTemp = sht.AutoFilter.Range.Offset(1, 0)
361 'Delete filtered range
362 Application.DisplayAlerts = False
363 rngTemp.Delete
364 Application.DisplayAlerts = True
365 sht.AutoFilterMode = False
366
367 sht.Range("B2:B" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).Value = sht.Name
368 End Select
369 Next sht
370
371 Set sht = Nothing
372 Set rngTemp = Nothing
373
374End Sub
375Sub GetERI(ByVal wsGPL As Worksheet)
376
377 'Estimated Reset Inventory
378 'Divide each POG's Units on Shelf by Each item's Units_Case, then average each line into new column.
379 'This will be multiplied by change in store count.
380 Dim i As Long
381 Dim j As Long
382 Dim lastRow As Long
383 Dim lastCol As Long
384 Dim lastArrayCol As Long 'Hack
385 Dim rng As Range 'Store data range
386 Dim arrStoreData() As Variant
387 Dim arrUnitsCs() As Variant
388 Dim arrCountStores() As Variant
389
390
391 With wsGPL
392 lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
393 lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
394
395 'Store data starting at column K, extend by two
396 'First extra is for averaging column, second is for count column
397 Set rng = .Range(.Cells(2, 11), .Cells(lastRow, lastCol + 2))
398
399 'Divide each PoGs' Units on Shelf by each item's Units_Case, then average each line into new column if value is not 0
400 arrStoreData = rng.Value
401 'Gobble up store count and units per case
402 arrUnitsCs = .Range("I2:I" & lastRow).Value
403 arrCountStores = .Range("E2:E" & lastRow).Value
404
405 'Last "column" in array is averaging element, will be referencing each loop
406 lastArrayCol = UBound(arrStoreData, 2)
407
408 'Loop through data array and get the averages
409 For i = LBound(arrStoreData, 1) To UBound(arrStoreData, 1)
410 'Initialize average and count column to non-empty
411 arrStoreData(i, lastArrayCol) = 0
412 arrStoreData(i, lastArrayCol - 1) = 0
413
414 'Run through all of the data and add it up
415 For j = LBound(arrStoreData, 2) To UBound(arrStoreData, 2) - 2
416 If arrStoreData(i, j) = Empty Then
417 arrStoreData(i, j) = 0
418 Else
419 'Add to average column, set data to 1 for count
420 arrStoreData(i, lastArrayCol - 1) = arrStoreData(i, lastArrayCol - 1) + arrStoreData(i, j)
421 arrStoreData(i, j) = 1
422 arrStoreData(i, lastArrayCol) = arrStoreData(i, lastArrayCol) + 1
423 End If
424 Next j
425
426 arrStoreData(i, lastArrayCol - 1) = arrStoreData(i, lastArrayCol - 1) / arrUnitsCs(i, 1)
427 arrStoreData(i, lastArrayCol) = arrStoreData(i, lastArrayCol) - arrCountStores(i, 1)
428
429 Next i
430
431 rng.Value = arrStoreData
432
433 'Format and name new columns
434 With .Cells(1, lastCol + 1)
435 .Value = "Avg Cs Pk"
436 .EntireColumn.NumberFormat = "0.00"
437 End With
438 .Cells(1, lastCol + 2).Value = "Change in stores carrying"
439 End With
440
441 Set rng = Nothing
442 Erase arrStoreData
443 Erase arrUnitsCs
444 Erase arrCountStores
445
446End Sub
447Sub Input_PoG_Usage()
448 'Taken from Stackoverflow.com
449 Dim sht As Worksheet, lastCol As Long, lastRow As Long, multiplier As Integer
450
451 Set sht = ActiveWorkbook.Worksheets("Addtnl Strs Per Item")
452 lastCol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
453
454 'Double For Loop
455 For i = 8 To lastCol
456 If Cells(1, i) <> vbNullString Then
457
458 ' \\// Set so that every pog will be used one time; the code below in green will offer the input box for variable usages.
459 multiplier = 1
460 ' //\\Application.InputBox("Number of stores using set " & Cells(1, i) & ".", , 1)
461 lastRow = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row
462
463 For j = 2 To lastRow
464 Cells(j, i).Value = multiplier * Cells(j, i)
465 Next j
466 End If
467 Next i
468
469End Sub
470Sub BuyerWarehouse(ByVal wsGPL As Worksheet, ByVal lastCol As Long, ByVal lastRow As Long)
471
472 Cells(1, lastCol + 1).Value = "Warehouse"
473 Cells(1, lastCol + 2).Value = "Buyer Number"
474
475 'Copy the data
476 Range(Cells(2, lastCol + 1), Cells(lastRow, lastCol + 2)).Value = wsGPL.Range("G2:H" & lastRow).Value
477
478End Sub
479Sub Calculate()
480
481 Dim i As Long, lastCol As Long, sht As Worksheet, lastRow As Long
482
483 Set sht = ActiveWorkbook.Worksheets("Addtnl Strs Per Item")
484 lastCol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
485 lastRow = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row
486
487 For i = 2 To lastRow
488 sht.Cells(i, lastCol - 2).Value = Application.WorksheetFunction.Sum(sht.Range(sht.Cells(i, 8), sht.Cells(i, lastCol - 3))) - sht.Cells(i, 5)
489 Next i
490
491End Sub
492Sub CAO_Relocate_New()
493 Application.ScreenUpdating = False
494
495 Dim sname As String
496 Dim relPath As String
497 Dim srcLstRow As Long
498 Dim dstLstRow As Long
499 Dim lstRow As Long
500 Dim fldrName As String
501 Dim wsDest As Worksheet
502 Dim sht As Worksheet
503 Dim wbSource As Workbook
504
505 Set wbSource = ActiveWorkbook
506
507 MkDir ("S:\Ryan Prince\CAO Reports POG\" & wbSource.Worksheets("Addtnl Strs Per Item").Range("A1").Value)
508
509 'Workbooks("RedditMemoryChallengeCode.xlsm").Worksheets("DNO").Copy
510 Workbooks("Buyer Report Generator V5.xlsm").Worksheets("DNO").Copy
511 Set wsDest = Workbooks(Workbooks.Count).Worksheets("DNO")
512
513 'Find last row of DNO sheet
514 dstLstRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row
515
516 For Each sht In wbSource.Sheets
517 Select Case sht.Name
518 Case "Group_PositionList", "Distribution", "Addtnl Strs Per Item"
519 'Do nothing
520 Case Else
521 srcLstRow = sht.Cells(Rows.Count, 1).End(xlUp).Row
522 lstRow = srcLstRow + dstLstRow - 2
523
524 'Paste in store code and UPCs
525 wsDest.Range(wsDest.Cells(dstLstRow, 1), wsDest.Cells(lstRow, 1)).Value = sht.Range("B2:B" & srcLstRow).Value
526 wsDest.Range(wsDest.Cells(dstLstRow, 3), wsDest.Cells(lstRow, 3)).Value = sht.Range("A2:A" & srcLstRow).Value
527
528 'Increment last row
529 dstLstRow = lstRow + 1
530
531 Application.DisplayAlerts = False
532 sht.Delete
533 Application.DisplayAlerts = True
534
535 End Select
536 Next sht
537
538 With wsDest
539 .Range("C:C").ColumnWidth = 14
540 .Range("B2:B" & lstRow).Value = Date
541 .Range("E3:E" & lstRow).Value = Range("E2").Value
542 .Range("F3:F" & lstRow).Value = Range("F2").Value
543 .Range("H3:H" & lstRow).Value = Range("H2").Value
544 .Range("J3:J" & lstRow).Value = Range("J2").Value
545 .Range("L3:L" & lstRow).Value = Range("L2").Value
546 .Range("M3:M" & lstRow).Value = 0
547
548 End With
549
550 sname = wbDest.Worksheets("DNO").Cells(2, 1).Value & ".txt"
551 relPath = "S:\Ryan Prince\CAO Reports POG\" & wbSource.Worksheets("Addtnl Strs Per Item").Range("A1").Value & "\" & "DNO"
552
553 wsDest.Parent.SaveAs Filename:=relPath & sname, FileFormat:=xlTextWindows
554 wsDest.Parent.Close False
555
556 Set wsDest = Nothing
557 Set sht = Nothing
558 Set wbSource = Nothing
559
560End Sub