· 6 years ago · Aug 03, 2019, 01:22 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 'Calculate made obsolete in the GetERI routine
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 'Multiply by change in store count
106 Dim e As Long, chng As Long
107
108 'Can be pulled into another sub and multiplied with arrays similar to other ones
109 With Sheets("Addtnl Strs Per Item")
110 lastcol = .Cells(2, Columns.Count).End(xlToLeft).Column + 1
111 lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
112 chng = lastcol - 3
113
114 .Cells(2, lastcol).Value = "Est Reset Inv"
115
116 For e = 3 To lastrow
117 If Cells(e, lastcol - 4).Value > 0 Then
118 Cells(e, lastcol).Value = .Cells(e, lastcol - 4).Value * Cells(e, chng).Value
119 End If
120 Next e
121
122 .Cells(1, lastcol).ColumnWidth = 11.25
123 .Range(Cells(2, lastcol), Cells(lastrow, lastcol)).Interior.ColorIndex = 43
124 .Range(Cells(2, lastcol), Cells(lastrow, lastcol)).EntireColumn.NumberFormat = "0"
125
126 'Conditional formatting would be a better choice here, I believe
127 For e = 3 To lastrow
128 If Round(Cells(e, lastcol)) < .Cells(e, chng) Then
129 .Cells(e, chng).Interior.ColorIndex = 43
130 .Cells(e, lastcol).Interior.ColorIndex = 46
131 End If
132 Next e
133 End With
134
135 'Hide POG Columns
136 Range(Cells(1, 8), Cells(1, lastcol - 4)).EntireColumn.Hidden = True
137
138
139 'Buyer Name Lookup
140 Range("A2").End(xlToRight).Select
141 Selection.Offset(, 1).Select
142 Selection.Value = "Buyer Name"
143
144 Selection.Offset(1, 0).Activate
145 ActiveCell.FormulaR1C1 = _
146 "=IF(RC[-2]>1,VLOOKUP(RC[-2],'[Buyer Report Generator V5.xlsm]Buyer_Report_Generator'!R2C1:R38C2,2,FALSE),"""")"
147 'ActiveCell.FormulaR1C1 = _
148 "=IF(RC[-2]>1,VLOOKUP(RC[-2],'[RedditMemoryChallengeCode.xlsm]Buyer_Report_Generator'!R2C1:R38C2,2,FALSE),"""")"
149
150 lastrow = Range("B2").End(xlDown).Row
151 ActiveCell.AutoFill Range(ActiveCell.Address, Cells(lastrow, ActiveCell.Column))
152
153
154 'Paste Values
155 Range("A2").Select
156 Selection.End(xlToRight).Select
157 Selection.EntireColumn.Copy
158
159 Range("A2").End(xlToRight).Select
160 Selection.Offset(-1, 0).Select
161
162 Selection.PasteSpecial Paste:=xlPasteValues
163 Application.CutCopyMode = False
164
165 'Final AutoFit & add filters
166 ActiveSheet.Range("A2").End(xlToRight).Select
167 Selection.EntireColumn.AutoFit
168 ActiveSheet.Range("A2").AutoFilter
169 ActiveSheet.Range("A1").Select
170
171 Workbooks("Buyer Report Generator V5.xlsm").Close False
172 wbGPL.Sheets("Addtnl Strs Per Item").Activate
173 MsgBox "Macro Complete"
174
175 Set wsGPL = Nothing
176 Set wbGPL = Nothing
177
178End Sub
179Sub RemoveDashOnes(ByRef lastrow As Long)
180 Dim i As Long
181
182 For i = lastrow To 2 Step -1
183 If Right(Cells(i, 2).Value, 2) = "-1" Then
184 Cells(i, 2).EntireRow.Delete shift:=xlUp
185 lastrow = lastrow - 1
186 End If
187 Next
188
189End Sub
190Sub CAO_Report(ByVal lastrow As Long, ByVal lastcol As Long)
191 Dim i As Long
192 Dim rng As Range
193 Dim strReplace As String
194 Dim strStoreNumber As String
195 Dim arrP_ID() As Variant
196
197 'Create new copies of report for later extraction
198 ActiveSheet.Copy After:=Worksheets(Sheets.Count)
199 ActiveSheet.Name = "Distribution"
200 ActiveSheet.Copy After:=Worksheets(Sheets.Count)
201 ActiveSheet.Name = "CAO Report"
202 Range("A:A").EntireColumn.Delete '1 column deleted
203 Range("B:J").EntireColumn.Delete '9 columns deleted
204
205 lastcol = lastcol - 10 '1 + 9 = 10
206
207 'Format new tab and strip down to needed data
208 Set rng = Range("A2:A" & lastrow)
209
210
211 'Format ye olde product IDs
212 arrP_ID = rng
213 For i = LBound(arrP_ID, 1) To UBound(arrP_ID, 1)
214 arrP_ID(i, 1) = Left(CStr(arrP_ID(i, 1)), Len(arrP_ID(i, 1)) - 1)
215 Next i
216 rng = arrP_ID
217 rng.NumberFormat = "0000000000000"
218 rng.ColumnWidth = 14
219
220 'Pull store numbers from POG names
221 For i = 2 To lastcol
222 strStoreNumber = Cells(1, i).Value
223 strReplace = Mid(strStoreNumber, Len(strStoreNumber) - 6, 3)
224 Cells(1, i).Value = strReplace
225 Next i
226
227 Set rng = Nothing
228 Erase arrP_ID
229
230End Sub
231Sub CAO_Breakout(ByVal lastrow As Long)
232
233 Dim rP_ID As Range
234 Dim i As Long
235 Dim lastcol As Long
236 Dim strStore As String
237 Dim wsCAO As Worksheet
238 Dim wsDuplicate As Worksheet
239
240 Set wsCAO = ActiveWorkbook.Worksheets("CAO Report")
241 lastcol = wsCAO.Cells(1, Columns.Count).End(xlToLeft).Column
242 Set rP_ID = wsCAO.Range("A1:A" & lastrow)
243
244 'Looper makes new tab for store, if it already exists, go to "ExistingStrNum"
245 On Error GoTo ExistingStrNum
246
247 For i = lastcol To 2 Step -1
248 Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsCAO.Cells(1, i).Value
249 Range("A1:A" & lastrow).Value = rP_ID.Value
250 Range("A1").ColumnWidth = 14
251 Range("A2:A" & lastrow).NumberFormat = "0000000000000"
252 Range("B1:B" & lastrow).Value = wsCAO.Range(wsCAO.Cells(1, i), wsCAO.Cells(lastrow, i)).Value
253
254Looper:
255 Next i
256
257DeleteAndExit:
258 '\\//When loop finishes, delete empty CAO report sheet and exit
259 Application.DisplayAlerts = False
260 wsCAO.Delete
261 Application.DisplayAlerts = True
262
263 Set rP_ID = Nothing
264 Set wsCAO = Nothing
265 Set wsDuplicate = Nothing
266
267 Exit Sub
268
269 'Add duplicate store number data to existing tab
270ExistingStrNum:
271 Application.DisplayAlerts = False
272 ActiveSheet.Delete
273 Application.DisplayAlerts = True
274
275 strStore = CStr(wsCAO.Cells(1, i))
276
277 If strStore <> "" Then
278 Set wsDuplicate = Sheets(strStore)
279 'wsDuplicate.Activate
280 Else
281 GoTo DeleteAndExit
282 End If
283
284 'When you find a duplicate, add it to the existing totals
285 Call SumDuplicateStoreData(wsDuplicate.Range(wsDuplicate.Cells(2, 2), wsDuplicate.Cells(lastrow, 2)), wsCAO.Range("B2:B" & lastrow))
286
287 Resume Looper
288
289End Sub
290'Add existing data and duplicate store data together, write in duplicate worksheet
291Private Sub SumDuplicateStoreData(ByRef rngDest As Range, ByRef rngCAO As Range)
292 Dim arrTotal() As Variant
293 Dim arrDuplicate() As Variant
294 Dim i As Long
295
296 arrTotal = rngDest.Value 'Existing data
297 arrDuplicate = rngCAO.Value 'New data
298
299 'Should put a check to make sure it's an array
300
301 For i = LBound(arrTotal, 1) To UBound(arrTotal, 1)
302
303 'If existing data is blank, but new data has a number value, overwrite
304 If arrTotal(i, 1) = Empty And arrDuplicate(i, 1) <> Empty Then
305 arrTotal(i, 1) = arrDuplicate(i, 1)
306
307 'If new data and existing data have number values, add them together
308 ElseIf IsNumeric(arrDuplicate(i, 1)) And IsNumeric(arrTotal(i, 1)) Then
309 arrTotal(i, 1) = arrTotal(i, 1) + arrDuplicate(i, 1)
310
311 'Otherwise, set data to 0
312 Else
313 arrTotal(i, 1) = 0
314 End If
315
316 Next i
317
318 'Write summed values back to sheet
319 rngDest.Value = arrTotal
320
321 Erase arrTotal
322 Erase arrDuplicate
323
324End Sub
325'Remove all 0s and blanks from the store tabs
326Sub CAO_Clean()
327
328 Dim sht As Worksheet
329 Dim rngTemp As Range
330
331 For Each sht In ActiveWorkbook.Worksheets
332 Select Case sht.Name
333 Case "Group_PositionList", "Distribution"
334 'do nothing
335 Case Else
336 'Filter for zero values
337 sht.UsedRange.AutoFilter field:=1, Criteria1:="<>"
338 sht.UsedRange.AutoFilter field:=2, Criteria1:="0", Operator:=xlOr, Criteria2:=""
339 'Offset needed to spare the headers, I think
340 Set rngTemp = sht.AutoFilter.Range.Offset(1, 0)
341 'Delete filtered range
342 Application.DisplayAlerts = False
343 rngTemp.Delete
344 Application.DisplayAlerts = True
345 sht.AutoFilterMode = False
346
347 sht.Range("B2:B" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).Value = sht.Name
348 End Select
349 Next sht
350
351 Set sht = Nothing
352 Set rngTemp = Nothing
353
354End Sub
355Sub GetERI(ByVal wsGPL As Worksheet)
356
357 'Estimated Reset Inventory
358 'Divide each POG's Units on Shelf by Each item's Units_Case, then average each line into new column.
359 'This will be multiplied by change in store count.
360 Dim i As Long
361 Dim j As Long
362 Dim lastrow As Long
363 Dim lastcol As Long
364 Dim lastArrayCol As Long 'Hack
365 Dim rng As Range 'Store data range
366 Dim arrStoreData() As Variant
367 Dim arrUnitsCs() As Variant
368 Dim arrCountStores() As Variant
369
370
371 With wsGPL
372 lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
373 lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
374
375 'Store data starting at column K, extend by two
376 'First extra is for averaging column, second is for count column
377 Set rng = .Range(.Cells(2, 11), .Cells(lastrow, lastcol + 2))
378
379 'Divide each PoGs' Units on Shelf by each item's Units_Case, then average each line into new column if value is not 0
380 arrStoreData = rng.Value
381 'Gobble up store count and units per case
382 arrUnitsCs = .Range("I2:I" & lastrow).Value
383 arrCountStores = .Range("E2:E" & lastrow).Value
384
385 'Last "column" in array is averaging element, will be referencing each loop
386 lastArrayCol = UBound(arrStoreData, 2)
387
388 'Loop through data array and get the averages
389 For i = LBound(arrStoreData, 1) To UBound(arrStoreData, 1)
390 'Initialize average and count column to non-empty
391 arrStoreData(i, lastArrayCol) = 0
392 arrStoreData(i, lastArrayCol - 1) = 0
393
394 'Run through all of the data and add it up
395 For j = LBound(arrStoreData, 2) To UBound(arrStoreData, 2) - 2
396 If arrStoreData(i, j) = Empty Then
397 arrStoreData(i, j) = 0
398 Else
399 'Add to average column, set data to 1 for count
400 arrStoreData(i, lastArrayCol - 1) = arrStoreData(i, lastArrayCol - 1) + arrStoreData(i, j)
401 arrStoreData(i, j) = 1
402 arrStoreData(i, lastArrayCol) = arrStoreData(i, lastArrayCol) + 1
403 End If
404 Next j
405
406 arrStoreData(i, lastArrayCol - 1) = arrStoreData(i, lastArrayCol - 1) / arrUnitsCs(i, 1)
407 arrStoreData(i, lastArrayCol) = arrStoreData(i, lastArrayCol) - arrCountStores(i, 1)
408
409 Next i
410
411 rng.Value = arrStoreData
412
413 'Format and name new columns
414 With .Cells(1, lastcol + 1)
415 .Value = "Avg Cs Pk"
416 .EntireColumn.NumberFormat = "0.00"
417 End With
418 .Cells(1, lastcol + 2).Value = "Change in stores carrying"
419 End With
420
421 Set rng = Nothing
422 Erase arrStoreData
423 Erase arrUnitsCs
424 Erase arrCountStores
425
426End Sub
427Sub Input_PoG_Usage()
428 'Taken from Stackoverflow.com
429 Dim sht As Worksheet, lastcol As Long, lastrow As Long, multiplier As Integer
430
431 Set sht = ActiveWorkbook.Worksheets("Addtnl Strs Per Item")
432 lastcol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
433
434 'Double For Loop
435 For i = 8 To lastcol
436 If Cells(1, i) <> vbNullString Then
437
438 ' \\// Set so that every pog will be used one time; the code below in green will offer the input box for variable usages.
439 multiplier = 1
440 ' //\\Application.InputBox("Number of stores using set " & Cells(1, i) & ".", , 1)
441 lastrow = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row
442
443 For j = 2 To lastrow
444 Cells(j, i).Value = multiplier * Cells(j, i)
445 Next j
446 End If
447 Next i
448
449End Sub
450Sub BuyerWarehouse(ByVal wsGPL As Worksheet, ByVal lastcol As Long, ByVal lastrow As Long)
451
452 Cells(1, lastcol + 1).Value = "Warehouse"
453 Cells(1, lastcol + 2).Value = "Buyer Number"
454
455 'Copy the data
456 Range(Cells(2, lastcol + 1), Cells(lastrow, lastcol + 2)).Value = wsGPL.Range("G2:H" & lastrow).Value
457
458End Sub
459Sub Calculate()
460
461 Dim i As Long, lastcol As Long, sht As Worksheet, lastrow As Long
462
463 Set sht = ActiveWorkbook.Worksheets("Addtnl Strs Per Item")
464 lastcol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
465 lastrow = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row
466
467 For i = 2 To lastrow
468 sht.Cells(i, lastcol - 2).Value = Application.WorksheetFunction.Sum(sht.Range(sht.Cells(i, 8), sht.Cells(i, lastcol - 3))) - sht.Cells(i, 5)
469 Next i
470
471End Sub
472Sub CAO_Relocate_New()
473 Application.ScreenUpdating = False
474
475 Dim sname As String
476 Dim relPath As String
477 Dim Srclstrow As Long
478 Dim Dstlstrow As Long
479 Dim lstrow As Long
480 Dim fldrName As String
481 Dim wsDest As Worksheet
482 Dim sht As Worksheet
483 Dim wbSource As Workbook
484
485 Set wbSource = ActiveWorkbook
486
487 MkDir ("S:\Ryan Prince\CAO Reports POG\" & wbSource.Worksheets("Addtnl Strs Per Item").Range("A1").Value)
488
489 'Workbooks("RedditMemoryChallengeCode.xlsm").Worksheets("DNO").Copy
490 Workbooks("Buyer Report Generator V5.xlsm").Worksheets("DNO").Copy
491 Set wsDest = Workbooks(Workbooks.Count).Worksheets("DNO")
492
493 'Find last row of DNO sheet
494 Dstlstrow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row
495
496 For Each sht In wbSource.Sheets
497 Select Case sht.Name
498 Case "Group_PositionList", "Distribution", "Addtnl Strs Per Item"
499 'Do nothing
500 Case Else
501 Srclstrow = sht.Cells(Rows.Count, 1).End(xlUp).Row
502 lstrow = Srclstrow + Dstlstrow - 2
503
504 'Paste in store code and UPCs
505 wsDest.Range(wsDest.Cells(Dstlstrow, 1), wsDest.Cells(lstrow, 1)).Value = sht.Range("B2:B" & Srclstrow).Value
506 wsDest.Range(wsDest.Cells(Dstlstrow, 3), wsDest.Cells(lstrow, 3)).Value = sht.Range("A2:A" & Srclstrow).Value
507
508 'Increment last row
509 Dstlstrow = lstrow + 1
510
511 Application.DisplayAlerts = False
512 sht.Delete
513 Application.DisplayAlerts = True
514
515 End Select
516 Next sht
517
518 With wsDest
519 .Range("C:C").ColumnWidth = 14
520 .Range("B2:B" & lstrow).Value = Date
521 .Range("E3:E" & lstrow).Value = Range("E2").Value
522 .Range("F3:F" & lstrow).Value = Range("F2").Value
523 .Range("H3:H" & lstrow).Value = Range("H2").Value
524 .Range("J3:J" & lstrow).Value = Range("J2").Value
525 .Range("L3:L" & lstrow).Value = Range("L2").Value
526 .Range("M3:M" & lstrow).Value = 0
527
528 End With
529
530 sname = wbDest.Worksheets("DNO").Cells(2, 1).Value & ".txt"
531 relPath = "S:\Ryan Prince\CAO Reports POG\" & wbSource.Worksheets("Addtnl Strs Per Item").Range("A1").Value & "\" & "DNO"
532
533 wsDest.Parent.SaveAs Filename:=relPath & sname, FileFormat:=xlTextWindows
534 wsDest.Parent.Close False
535
536 Set wsDest = Nothing
537 Set sht = Nothing
538 Set wbSource = Nothing
539
540End Sub