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