Last Updated Buyer Report Code

Option Explicit

Sub Master()

    Dim lastCol As Long
    Dim lastRow As Long
    Dim wsGPL As Worksheet
    Dim wbGPL As Workbook

    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

    Application.ScreenUpdating = False

    'Variable for main worksheet
    Set wsGPL = Sheets("Group_PositionList")

    'These are used in a few places, might as well carry it through subs that update the table
    lastRow = wsGPL.Cells(Rows.Count, 1).End(xlUp).Row
    lastCol = wsGPL.Cells(1, Columns.Count).End(xlToLeft).Column

    '\\//CAO Processes
    Call RemoveDashOnes(lastRow)
    Call CAO_Report(lastRow, lastCol)
    Call CAO_Breakout(lastRow)
    Call CAO_Clean
    '//\\

    'Delete Max Facings Column
    ActiveWorkbook.Sheets("Group_PositionList").Activate
    wsGPL.Range("K1").EntireColumn.Delete

    'Convert all movements & counts to numbers

        ActiveSheet.Range(Cells(2, 5), Cells(lastRow, lastCol)).Select
            With Selection
                .NumberFormat = "General"
                .Value = .Value
            End With

    'Get Estimated Reset Inventory, this tells the inventory for the additional stores carrying each item.
    'Change all POG UPC counts to 1
    Call GetERI

    'Build Additional Stores Using Item Sheet
        With ActiveWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Addtnl Strs Per Item"
        End With
    wsGPL.Activate

    '=====Copy the data=====
    wsGPL.Range("A1:F" & Range("F" & Rows.Count).End(xlUp).Row).Copy
    'Activate the destination worksheet
    Sheets("Addtnl Strs Per Item").Activate
    'Select the target range
    Range("A1").Select
    'Paste in the target destination
    ActiveSheet.Paste
    Application.CutCopyMode = False

    wsGPL.Activate
    wsGPL.Range("J1:J" & Range("J" & Rows.Count).End(xlUp).Row).Copy
    'Activate the destination worksheet
    Sheets("Addtnl Strs Per Item").Activate
    'Select the target range
    Range("G1").Select
    'Paste in the target destination
    ActiveSheet.Paste
    Application.CutCopyMode = False

    '=====From Copy Headers=====
    'Find Last Column Used
    lastCol = wsGPL.Cells(1, Columns.Count).End(xlToLeft).Column
    lastRow = wsGPL.Cells(Rows.Count, 1).End(xlUp).Row
    'Copy through last header
    wsGPL.Select
    ActiveSheet.Range(Cells(1, 11), Cells(lastRow, lastCol - 1)).Select
        Selection.Copy
    'Activate Target Worksheet
    Sheets("Addtnl Strs Per Item").Activate
    'Select Target Range
    Range("H1").Select
    'Paste in Target Destination
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Cells.EntireColumn.AutoFit



    '=====Run Input Macros=====

    'Run Input_PoG_Usage
    Call Input_PoG_Usage

'Add header to last column
    With ActiveSheet
        Range("A1").End(xlToRight).Select
        ActiveCell.Offset(, 1).Activate
'Changed from Number of stores carrying item
        ActiveCell.Value = "Change in stores carrying"

'Color Store Count
        .Range("A1").End(xlToRight).Select
            Selection.EntireColumn.Interior.Color = RGB(200, 200, 200)
    End With

'Run BuyerWarehouse
    Call BuyerWarehouse

'Run Calculate
    Call Calculate

'=====Formatting=====

'Color Rows based on Max Position Count
    Range("A2:G" & Range("G" & Rows.Count).End(xlUp).Row).Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$G2=0"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 6908415
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

'Freeze Top Row, Rename Headers, & AutoFit Columns
Rows("2:2").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
With ActiveSheet
    .Range("A1").Value = "Order #"
    .Range("B1").Value = "UPC"
    .Range("E1").Value = "Current Store Count"
    .Range("F1").Value = "Mvmnt"
    .Cells.EntireColumn.AutoFit
    .Range("A1").Select
End With

'Add Title & Reset Date
    Rows("1:1").Select
    Selection.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Value = Application.InputBox("Buyer Report Title?")
    Range("A2").Select
    Selection.End(xlToRight).Select
    Selection.Offset(-1, -2).Value = "Reset Date: "
    Selection.Offset(-1, -2).HorizontalAlignment = xlRight
    Selection.Offset(-1, -1).Value = Application.InputBox("Reset Date?")
    Selection.Offset(-1, -1).HorizontalAlignment = xlLeft
    Set wbGPL = ActiveWorkbook
'CAO Relocate
    Call CAO_Relocate_New

'Add Estimated Reset Inventory and multiply by Change in store count.
    wsGPL.Activate
    ActiveSheet.Range("A1").Select
    Selection.End(xlToRight).Select
    Selection.Offset(, -1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Offset(, 1).Select
    Selection.Copy

'Activate the destination worksheet
    Sheets("Addtnl Strs Per Item").Activate
'Select the target range
    With ActiveSheet
        Range("A2").End(xlToRight).Select
        ActiveCell.Offset(, 1).Select
    End With
'Paste in the target destination
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With ActiveSheet
        .Cells.EntireColumn.AutoFit
        .Range("A:A").ColumnWidth = 9.6
    End With
'Multiply by change in store count
Dim e As Long, f As Long, chng As Long

    With Sheets("Addtnl Strs Per Item")
    lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    chng = .Cells(3, lastCol - 3).Column

        For e = 3 To lastRow
            For f = lastCol To lastCol
                If Cells(e, lastCol).Value > 0 Then
                    If Cells(e, lastCol).Value = "" Then
                        Cells(e, lastCol).Value = "0"
                    End If
                    Cells(e, lastCol) = Cells(e, lastCol) * Cells(e, chng)
                End If
           Next
        Next e
    .Cells(1, lastCol).ColumnWidth = 11.25
    .Range(Cells(3, lastCol), Cells(lastRow, lastCol)).Interior.ColorIndex = 43
    .Range(Cells(3, lastCol), Cells(lastRow, lastCol)).EntireColumn.NumberFormat = "0"
    .Cells(2, lastCol).Value = "Est Reset Inv"

        For e = 3 To lastRow
            If Round(Cells(e, lastCol)) < .Cells(e, chng) Then
                .Cells(e, chng).Interior.ColorIndex = 43
                .Cells(e, lastCol).Interior.ColorIndex = 46
            End If
        Next e
    End With

'Hide POG Columns
    Range("H1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.EntireColumn.Hidden = True
    Range("A2").End(xlToRight).Select
    Selection.Offset(, -3).EntireColumn.Hidden = False


'Buyer Name Lookup
    Range("A2").End(xlToRight).Select
    Selection.Offset(, 1).Select
    Selection.Value = "Buyer Name"
    Selection.Offset(, -2).EntireColumn.NumberFormat = "General"
    Selection.Value = Selection.Value

    Selection.Offset(1, 0).Activate
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-2]>1,VLOOKUP(RC[-2],'[Buyer Report Generator V6 (Working).xlsm]Buyer_Report_Generator'!R2C1:R38C2,2,FALSE),"""")"

    lastRow = Range("B2").End(xlDown).Row
    ActiveCell.AutoFill Range(ActiveCell.Address, Cells(lastRow, ActiveCell.Column))


'Paste Values
    Range("A2").Select
    Selection.End(xlToRight).Select
    Selection.EntireColumn.Copy

    Range("A2").End(xlToRight).Select
    Selection.Offset(-1, 0).Select

    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

'Final AutoFit & add filters
    ActiveSheet.Range("A2").End(xlToRight).Select
    Selection.EntireColumn.AutoFit
    ActiveSheet.Range("A2").AutoFilter
    ActiveSheet.Range("A1").Select

'Hide Group_PositionList Sheet
    wsGPL.Visible = False

    'Workbooks("Buyer Report Generator V6 (Working).xlsm").Close False
    wbGPL.Sheets("Addtnl Strs Per Item").Activate
    MsgBox "Macro Complete"

End Sub
Sub RemoveDashOnes(ByRef lastRow As Long)
    Dim i As Long

    For i = lastRow To 2 Step -1
        If Right(Cells(i, 2).Value, 2) = "-1" Then
            Cells(i, 2).EntireRow.Delete shift:=xlUp
            lastRow = lastRow - 1
        End If
    Next

End Sub
Sub CAO_Report(ByVal lastRow As Long, ByVal lastCol As Long)
    'Dim lastCol as long    'Since these are copies you can just take the lastrow and lastCol from the other place
    'Dim lastRow as long
    Dim i As Long
    Dim rng As Range
    Dim strReplace As String
    Dim strStoreNumber As String
    Dim arrP_ID() As Variant

    'Create new tab - Yeah, but why?
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    ActiveSheet.Name = "Distribution"
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    ActiveSheet.Name = "CAO Report"
    Range("A:A").EntireColumn.Delete        '1 column deleted
    Range("B:J").EntireColumn.Delete        '9 columns deleted

    lastCol = lastCol - 10                  '1 + 9 = 10

    'Format new tab and strip down to needed data
    Set rng = Range("A2:A" & lastRow)


    'Format ye olde product IDs
    arrP_ID = rng
    For i = LBound(arrP_ID, 1) To UBound(arrP_ID, 1)
        arrP_ID(i, 1) = Left(CStr(arrP_ID(i, 1)), Len(arrP_ID(i, 1)) - 1)
    Next i
    rng = arrP_ID
    rng.NumberFormat = "0000000000000"
    rng.ColumnWidth = 14

    'Pull store numbers from POG names
    For i = 2 To lastCol
        strStoreNumber = Cells(1, i).Value
        strReplace = Mid(strStoreNumber, Len(strStoreNumber) - 6, 3)
        Cells(1, i).Value = strReplace
    Next i

    Set rng = Nothing
    Erase arrP_ID

End Sub
Sub CAO_Breakout(ByVal lastRow As Long)

    Dim rP_ID As Range
    Dim i As Long
    Dim lastCol As Long
    Dim strStore As String
    Dim wsCAO As Worksheet
    Dim wsDuplicate As Worksheet

    Set wsCAO = ActiveWorkbook.Worksheets("CAO Report")
    lastCol = wsCAO.Cells(1, Columns.Count).End(xlToLeft).Column
    Set rP_ID = wsCAO.Range("A1:A" & lastRow)

    'Looper makes new tab for store, if it already exists, go to "ExistingStrNum"
    On Error GoTo ExistingStrNum

    For i = lastCol To 2 Step -1
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsCAO.Cells(1, i).Value
        Range("A1:A" & lastRow).Value = rP_ID.Value
        Range("A1").ColumnWidth = 14
        Range("A2:A" & lastRow).NumberFormat = "0000000000000"
        Range("B1:B" & lastRow).Value = wsCAO.Range(wsCAO.Cells(1, i), wsCAO.Cells(lastRow, i)).Value

Looper:
    Next i

DeleteAndExit:
    '\\//When loop finishes, delete empty CAO report sheet and exit
    Application.DisplayAlerts = False
    wsCAO.Delete
    Application.DisplayAlerts = True

    Set rP_ID = Nothing
    Set wsCAO = Nothing
    Set wsDuplicate = Nothing

    Exit Sub

    'Add duplicate store number data to existing tab
ExistingStrNum:
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True

    strStore = CStr(wsCAO.Cells(1, i))

    If strStore <> "" Then
        Set wsDuplicate = Sheets(strStore)
        wsDuplicate.Activate
    Else
        GoTo DeleteAndExit
    End If

    'When you find a duplicate, add it to the existing totals
    'vvv u/Aftermathrar 's solution to summing the rows upon duplicates.
    Call SumDuplicateStoreData(wsDuplicate.Range(wsDuplicate.Cells(2, 2), wsDuplicate.Cells(lastRow, 2)), wsCAO.Range("B2:B" & lastRow))



    Resume Looper

End Sub
'Add existing data and duplicate store data together, write in duplicate worksheet
Private Sub SumDuplicateStoreData(ByRef rngDest As Range, ByRef rngCAO As Range)
    Dim arrTotal() As Variant
    Dim arrDuplicate() As Variant
    Dim i As Long

    arrTotal = rngDest.Value            'Existing data
    arrDuplicate = rngCAO.Value         'New data

    'Should put a check to make sure it's an array

    For i = LBound(arrTotal, 2) To UBound(arrTotal, 2)

        'If existing data is blank, but new data has a number value, overwrite
        If arrTotal(i, 1) = Empty And arrDuplicate(i, 1) <> Empty Then
            arrTotal(i, 1) = arrDuplicate(i, 1)

        'If new data and existing data have number values, add them together
        ElseIf IsNumeric(arrDuplicate(i, 2)) And IsNumeric(arrTotal(i, 2)) Then
            arrTotal(i, 2) = arrTotal(i, 2) + arrDuplicate(i, 2)

        'Otherwise, set data to 0
        Else
            arrTotal(i, 2) = 0
        End If

    Next i

    'Write summed values back to sheet
    rngDest.Value = arrTotal

    Erase arrTotal
    Erase arrDuplicate

End Sub
Sub CAO_Clean()

    Dim sht As Worksheet
    Dim rngTemp As Range

    For Each sht In ActiveWorkbook.Worksheets
        Select Case sht.Name
            Case "Group_PositionList", "Distribution"
                'do nothing
            Case Else
                'Filter for zero values
                sht.UsedRange.AutoFilter field:=1, Criteria1:="<>"
                sht.UsedRange.AutoFilter field:=2, Criteria1:="0", Operator:=xlOr, Criteria2:=""
                'Offset needed to spare the headers, I think
                Set rngTemp = sht.AutoFilter.Range.Offset(1, 0)
                'Delete filtered range
                Application.DisplayAlerts = False
                rngTemp.Delete
                Application.DisplayAlerts = True
                sht.AutoFilterMode = False
        End Select
    Next sht

End Sub
Sub GetERI()

    'Estimated Reset Inventory
    'Divide each POG's Units on Shelf by Each item's Units_Case, then average each line into new column.
    'This will be multiplied by change in store count.
    Dim e As Long, lastRow As Long, lastCol As Long, f As Long, rng As Range, rng2 As Range, wsGPL As Worksheet, cell As Range

    Set wsGPL = ActiveWorkbook.Sheets("Group_PositionList")

        With wsGPL
            lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

            Set rng = Range(Cells(2, 11), Cells(lastRow, lastCol))

    'Change 0s to empty
            For Each cell In rng
                If cell.Value = 0 Then
                    cell.Value = Empty
                ElseIf cell.Value <> 0 Then
                    cell.Value = cell.Value
                End If
            Next

    'Divide each PoGs' Units on Shelf by each item's Units_Case, then average each line into new column if value is not 0
            rng.NumberFormat = "General"
            rng.Value = rng.Value
            For e = 2 To lastRow
                For f = 11 To lastCol
                    If Cells(e, f).Value <> Empty Then
                        Cells(e, f).Value = .Cells(e, f).Value / Cells(e, 9).Value
                        'Cells(e, f).NumberFormat = "0.00"
                        Cells(e, lastCol + 1).Value = Application.WorksheetFunction.AverageIf(Range(Cells(e, 11), Cells(e, lastCol)), ">0")
                    End If
                Next
            Next e

    'Format new column
        Range("A1").Select
        Selection.End(xlToRight).Offset(, 1).Select
        Selection.Value = "Avg Cs Pk"
        Selection.EntireColumn.NumberFormat = "0.00"

    'If a value on Group Position List is  more than .01, make it 1.  If not, make it 0.

        For Each cell In rng
            If cell.Value <> Empty Then
                cell.Value = 1
            ElseIf cell.Value = Empty Then
                cell.Value = 0
                cell.NumberFormat = "0"
            End If
        Next

        End With

    Dim g As Long, lastcol2 As Long
        For g = 2 To lastRow
            lastcol2 = wsGPL.Cells(1, Columns.Count).End(xlToLeft).Column
            If Cells(g, lastCol).Value = "" Then
                Cells(g, lastCol) = "0"
            End If
        Next

End Sub
Sub Input_PoG_Usage()
    'Taken from Stackoverflow.com
    Dim sht As Worksheet, lastCol As Long, lastRow As Long, multiplier As Integer
    Dim i As Long, j As Long

    Set sht = ActiveWorkbook.Worksheets("Addtnl Strs Per Item")
    lastCol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column

    Application.ScreenUpdating = False
    'Double For Loop
    For i = 8 To lastCol
        If Cells(1, i) <> vbNullString Then

            '     \\// Set so that every pog will be used one time; the code below in green will offer the input box for variable usages.
            'multiplier = 1
            '     //\\Application.InputBox("Number of stores using set " & Cells(1, i) & ".", , 1)
            lastRow = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row

            For j = 2 To lastRow
                If Cells(j, i) = "" Then
                    Cells(j, i) = "0"
                End If
            Cells(j, i) = 1 * Cells(j, i)    'Replace 1 with Multiplier if needed
            Next j
        End If
    Next i
    Application.ScreenUpdating = False

End Sub
Sub BuyerWarehouse()

Dim lastCol As Long, wsGPL As Worksheet

Set wsGPL = ActiveWorkbook.Sheets("Group_PositionList")

    With ActiveSheet.Select
        Range("A1").End(xlToRight).Select
    End With
    ActiveCell.Offset(, 1).Activate
    ActiveCell.Value = "Warehouse"
    ActiveCell.Offset(, 1).Activate
    ActiveCell.Value = "Buyer Number"

    lastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

    'Copy the data
    wsGPL.Range("G2:H" & Range("H" & Rows.Count).End(xlUp).Row).Copy
    'Activate the destination worksheet
    Sheets("Addtnl Strs Per Item").Activate
    'Select the target range
    Cells(2, lastCol - 1).Select
    'Paste in the target destination
    ActiveSheet.Paste
    Application.CutCopyMode = False

End Sub
Sub Calculate()

    Dim i As Long, lastCol As Long, sht As Worksheet, lastRow As Long

    Set sht = ActiveWorkbook.Worksheets("Addtnl Strs Per Item")
    lastCol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
    lastRow = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row

    For i = 2 To lastRow
        sht.Cells(i, lastCol - 2).Value = Application.WorksheetFunction.Sum(sht.Range(sht.Cells(i, 8), sht.Cells(i, lastCol - 3))) - sht.Cells(i, 5)
    Next i

End Sub
Sub CAO_Relocate_New()
    Application.ScreenUpdating = False

    Dim wbSource As Workbook, wbDest As Workbook, sht As Worksheet, sname As String, _
    relPath As String, Srclstrow As Long, Dstlstrow As Long, lstrow As Long, fldrName As String, newbook As Workbook

    Set wbSource = ActiveWorkbook

    MkDir ("S:\Ryan Prince\CAO Reports POG\" & wbSource.Worksheets("Addtnl Strs Per Item").Range("A1").Value)

    Set newbook = Workbooks.Add
    Workbooks("Buyer Report Generator V6 (Working).xlsm").Worksheets("DNO").Copy before:=newbook.Sheets(1)
            Application.DisplayAlerts = False
            newbook.Sheets("Sheet1").Delete
            Application.DisplayAlerts = True
            Set wbDest = newbook

    For Each sht In wbSource.Sheets
        If sht.Name = "Group_PositionList" Or sht.Name = "Distribution" Or sht.Name = "Addtnl Strs Per Item" Then
        Else
            'Destination book
            Srclstrow = sht.Cells(Rows.Count, 1).End(xlUp).Row
            Dstlstrow = wbDest.Worksheets("DNO").Cells(Rows.Count, 1).End(xlUp).Row

                sht.Range("A2:A" & Srclstrow).Copy wbDest.Worksheets("DNO").Range("C" & Dstlstrow)
                sht.Range("B2:B" & Srclstrow).Copy wbDest.Worksheets("DNO").Range("A" & Dstlstrow)

                Application.DisplayAlerts = False
                sht.Delete
                Application.DisplayAlerts = True
        End If
    Next

    lstrow = wbDest.Worksheets("DNO").Cells(Rows.Count, 1).End(xlUp).Row

    With wbDest.Worksheets("DNO")
        .Range("C:C").ColumnWidth = 14
        .Range("B2:B" & lstrow).Value = Date
        .Range("E2:E" & lstrow).Value = Range("E2").Value
        .Range("F2:F" & lstrow).Value = Range("F2").Value
        .Range("H2:H" & lstrow).Value = Range("H2").Value
        .Range("J2:J" & lstrow).Value = Range("J2").Value
        .Range("L2:L" & lstrow).Value = Range("L2").Value
        .Range("M2:M" & lstrow).Value = 0

    End With

    sname = wbDest.Worksheets("DNO").Cells(2, 1).Value & ".txt"
    relPath = "S:\Ryan Prince\CAO Reports POG\" & wbSource.Worksheets("Addtnl Strs Per Item").Range("A1").Value & "\" & "DNO"

    wbDest.SaveAs Filename:=relPath & sname, FileFormat:=xlTextWindows
    wbDest.Close False

End Sub
Sub Multiply_By_Change()

Dim e As Long, f As Long

With Sheets("Addtnl Strs Per Item")
    lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    chng = .Cells(3, lastCol - 3).Column

    For e = 3 To lastRow
        For f = lastCol To lastCol
            If Cells(e, lastCol).Value > 0 Then
                  Cells(e, lastCol).Value = .Cells(e, lastCol).Value * Cells(e, chng).Value
            End If
        Next
        If Round(Cells(e, lastCol)) < .Cells(e, chng) Then
            .Cells(e, chng).Interior.ColorIndex = 43
            .Cells(e, lastCol).Interior.ColorIndex = 46
        End If
    Next e

.Cells(1, lastCol).ColumnWidth = 11.25
.Range(Cells(2, lastCol), Cells(lastRow, lastCol)).Interior.ColorIndex = 43
.Range(Cells(2, lastCol), Cells(lastRow, lastCol)).EntireColumn.NumberFormat = "0"
.Cells(2, lastCol).Value = "Est Reset Inv"

End With

End Sub