Hi all, This macro takes about 20 minutes to run. The computer has a AMD Athlon(tm) II P340 Dual-Core Processor 2.20GHz and 3GB of RAM, if that matters. When I run the macro the CPU does hit 100% usage a few times for 20 or so seconds. I am probably just good enough at writing macros to be dangerous. A lot of this is based on the little I know, a lot that I am still learning, and things I have found on internet searches. THANKS for the help. Option Explicit
Option Base 1
' Declaration of Variables
Public wbnames() As String
Public wbpath() As String
Public wsnames() As String
Public a, b, c, i, j, k, r, y, EPFileIndex, EPSheetIndex, bottomrow, TotalRows, MaxArray As Long
Public showStatusBar, myMatch As Boolean
Dim wb, EPwb, FFwb, w As Workbook
Dim WHmax, DesLen, lastrow4, addstorenum1, addstorenum2, addstorenum3, addstorenum4, addstorenum5, size1, lastrow2, lastrow3, UPC, Des, WHOH, CHOH, DPOH, FEOH, SCOH, CHmax, DPmax, FEmax, SCmax, T2CH, T2DP, T2FE, T2SC, CHdiff, DPdiff, FEdiff, SCdiff As Long
Dim ws, EPws As Worksheet
Dim InOpenBook
Dim fileToOpen
Dim myArray()
Public myCurrentDate, ClientCopyFileName As String
Dim ClientCopyFilePath
Sub Inventory()
' This macro performs the following functions
' 1 - Open existing Inventory Report
' 2 - Reformat report to give the count of each style per location
' 3 - Include MAX fill levels and Minimum Acceptable Quantity (MAQ) levels for each style by location
' 4 - Identify the qty of each UPC to fill from the warehouse to the individual stores
' 5 - Identify the qty of each UPC from other stores that are required to get above MAQ
' 6 - Save the results as a new file
'
'
'
'
'
'
'
'
'
Application.ScreenUpdating = False ' Turns off screen refreshing to speed up macro
showStatusBar = Application.DisplayStatusBar ' identify the current Status bar information
Application.DisplayStatusBar = True ' turn on the status bar
Application.StatusBar = "Please be patient..."
ThisWorkbook.Sheets("Transfer").Visible = True ' unhide Transfer worksheet
ThisWorkbook.Sheets("Data").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("Data2").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("Data3").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to FE").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("CH to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("CH to FE").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("CH to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("DP to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("DP to FE").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("DP to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("FE to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("FE to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("FE to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("SC to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("SC to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("SC to FE").Visible = True ' unhide Data worksheet
' clear old data from the Data sheets
ThisWorkbook.Sheets("Data").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
'deletes the cells, rather than clearing them
ThisWorkbook.Sheets("Data2").Activate
Cells.Select
Selection.RemoveSubtotal
Selection.Clear
Range("A1").Select
ThisWorkbook.Sheets("Data3").Activate
Cells.Select
Selection.Clear
Range("A1").Select
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("Transfer").Activate
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to CH").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to DP").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to FE").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to SC").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' 1 - Open existing Inventory Report
' Ask user if workbook with Inventory Report is currently open
InOpenBook = MsgBox("Is the Inventory Report currently open?", vbYesNo)
' If the user specifies that the Inventory data is in an open workbook, then
' compile a list of all open workbooks and prompts the user to choose which book contains the data
If InOpenBook = vbYes Then
' How many workbooks are currently open?
i = Workbooks.Count
' Redeclare arrays so that each array has exactly one entry for each open file
ReDim wbnames(i) As String
ReDim wbpaths(i) As String
j = 1
For Each wb In Workbooks
wbnames(j) = wb.Name
wbpaths(j) = wb.FullName
j = j + 1
Next wb
WorkbookChooser.Show
Set EPwb = Workbooks(wbnames(EPFileIndex))
EPwb.Activate
Else:
' If the user specifies that the inventory data is not in an open workbook, then
' prompt the user to find the file which contains the data. It then opens the selected file
If InOpenBook = vbNo Then
fileToOpen = Application.GetOpenFilename(FilterIndex:=56, _
MultiSelect:=False, Title:="Select Export Packages Report")
If fileToOpen <> False Then
' MsgBox fileToOpen
k = 0
For Each wb In Workbooks
If wb.FullName = fileToOpen Then
k = k + 1
Set EPwb = Workbooks(wb.Name)
End If
Next wb
If k = 0 Then
Workbooks.Open (fileToOpen)
Set EPwb = ActiveWorkbook
End If
EPwb.Activate
End If
Else:
' if the user quits then exit this macro
ThisWorkbook.Sheets("Transfer").Visible = False ' rehide Transfer sheet
ThisWorkbook.Sheets("Data").Visible = False ' rehide Data sheet
Application.StatusBar = False ' turns off my custom status bar messages
Application.DisplayStatusBar = showStatusBar ' returns the status bar to its original state
Application.ScreenUpdating = True 'Re-enables the screen refreshing now that the macro is finished
Exit Sub
End If
End If
Application.StatusBar = "Importing Inventory Data..."
' At this point, the Inventory report is open and active. Now we need to identify the sheet with the data.
' start by counting the number of sheets in the book
' if number of sheets = 1, then it should be obvious
' Otherwise, cycle through sheets and show user a dialog box to select the correct sheet
i = ActiveWorkbook.Worksheets.Count
ReDim wsnames(i) As String
If i = 1 Then
Set EPws = ActiveSheet
Else:
j = 1
For Each ws In Worksheets
wsnames(j) = ws.Name
j = j + 1
Next ws
WorksheetChooser.Show
Set EPws = Sheets(wsnames(EPSheetIndex))
End If
' Copy Raw Data from Inventory File into the formatter worksheet
EPws.Activate
ActiveSheet.Range("A1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
TotalRows = Selection.Rows.Count
ActiveSheet.Range(Cells(1, 1), Cells(TotalRows, 17)).Select
Selection.Copy Destination:=ThisWorkbook.Sheets("Data").Range("A1")
Application.CutCopyMode = False
If InOpenBook = vbNo Then EPwb.Close
ThisWorkbook.Sheets("Data").Activate
'added line below and changed two lines down to R from N
ActiveSheet.Range("Q1").Select
'ActiveSheet.Range("R1").Select
ActiveSheet.Range("r1:t1").Select
Selection.Copy
ActiveSheet.Range(Cells(2, 18), Cells(TotalRows, 20)).Select
Selection.PasteSpecial
Application.CutCopyMode = False
'paste into data2 for subtotals
ActiveSheet.Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Data2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Sort Key1:=Range("j1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=True, Orientation:=xlSortColumns
Columns("A:D").Select
Selection.Delete Shift:=xlRight
Columns("D:O").Select
Selection.Delete Shift:=xlRight
Columns("D:D").Select
Selection.Cut
Range("A1").Activate
Selection.Insert Shift:=xlRight
'make sure the sort is right so the vlookup works
'*************************************************
ActiveSheet.Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3, 4) _
, Replace:=True, PageBreaks:=False, SummaryBelowData:=False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:D").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Data3").Select
ActiveSheet.Paste
' 2 - Reformat report to give the count of each size of each style per location
Sheets("Data").Select
Range("m2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Transfer").Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'copy description down with store# added
Range("a6").Select
Range(Selection, Selection.End(xlDown)).Select
'ActiveWorkbook.Worksheets("Transfer").Sort.SortFields.Clear
'this step below might not work. might need to specify range differently.
ActiveWorkbook.Worksheets("Transfer").Sort.SortFields.Add Key:=Range( _
Selection, Selection.End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveSheet.Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow2 = Selection.Rows.Count
Range("A6").Select
y = 1
Do Until y = lastrow2
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
ActiveCell.Offset(5, 0).Select
y = y + 1
Loop
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow4 = Selection.Rows.Count
For y = 6 To lastrow4 + 5 Step 5
addstorenum1 = Cells(y, 1).Value
addstorenum1 = (addstorenum1 + "-257731")
ActiveSheet.Cells(y, 1).Value = addstorenum1
addstorenum2 = Cells(y + 1, 1).Value
addstorenum2 = (addstorenum2 + "-257732")
ActiveSheet.Cells(y + 1, 1).Value = addstorenum2
addstorenum3 = Cells(y + 2, 1).Value
addstorenum3 = (addstorenum3 + "-257733")
ActiveSheet.Cells(y + 2, 1).Value = addstorenum3
addstorenum4 = Cells(y + 3, 1).Value
addstorenum4 = (addstorenum4 + "-257734")
ActiveSheet.Cells(y + 3, 1).Value = addstorenum4
addstorenum5 = Cells(y + 4, 1).Value
addstorenum5 = (addstorenum5 + "-257735")
ActiveSheet.Cells(y + 4, 1).Value = addstorenum5
Next y
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
' Copy the Calculation Formulas down the transfer sheet
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow3 = Selection.Rows.Count
ActiveSheet.Range("b3:be3").Select
Selection.Copy
ActiveSheet.Range(Cells(6, 2), Cells(lastrow3 + 5, 57)).Select
Selection.PasteSpecial
Application.CutCopyMode = False
' 3 - Include MAX fill levels and Minimum Acceptable Quantity (MAQ) levels for each UPC by location
'3.1 this will come later...
' 4 - Identify the qty of each style to fill from the warehouse to the individual stores
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow3 = Selection.Rows.Count
For r = 6 To lastrow3 + 5 Step 5
For size1 = 2 To 28
Des = Cells(r, 1).Value
DesLen = Len(Des)
Des = Left(Des, DesLen - 7)
' capture des without store number.
SCOH = Cells(r, size1).Value
CHOH = Cells(r + 1, size1).Value
FEOH = Cells(r + 2, size1).Value
DPOH = Cells(r + 3, size1).Value
WHOH = Cells(r + 4, size1).Value
' how do i create the max table?
SCmax = Cells(r, size1 + 28).Value
CHmax = Cells(r + 1, size1 + 28).Value
FEmax = Cells(r + 2, size1 + 28).Value
DPmax = Cells(r + 3, size1 + 28).Value
WHmax = Cells(r + 4, size1 + 28).Value
T2CH = 0
T2DP = 0
T2FE = 0
T2SC = 0
Do Until WHOH = 0
CHdiff = CHmax - CHOH
DPdiff = DPmax - DPOH
FEdiff = FEmax - FEOH
SCdiff = SCmax - SCOH
If CHdiff > 0 Then
CHOH = CHOH + 1
T2CH = T2CH + 1
WHOH = WHOH - 1
End If
If WHOH = 0 Then Exit Do
If DPdiff > 0 Then
DPOH = DPOH + 1
T2DP = T2DP + 1
WHOH = WHOH - 1
If WHOH = 0 Then Exit Do
End If
If FEdiff > 0 Then
FEOH = FEOH + 1
T2FE = T2FE + 1
WHOH = WHOH - 1
If WHOH = 0 Then Exit Do
End If
If SCdiff > 0 Then
SCOH = SCOH + 1
T2SC = T2SC + 1
WHOH = WHOH - 1
If WHOH = 0 Then Exit Do
End If
If SCdiff <= 0 And CHdiff <= 0 And FEdiff <= 0 And DPdiff <= 0 Then WHOH = 0
Loop
'copy results of each upc to correct sheet
'can i remove the store number from the des to make it narrower?
If T2CH > 0 Then
ThisWorkbook.Sheets("WH to CH").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2CH
ThisWorkbook.Sheets("Transfer").Activate
End If
If T2DP > 0 Then
ThisWorkbook.Sheets("WH to DP").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2DP
ThisWorkbook.Sheets("Transfer").Activate
End If
If T2FE > 0 Then
ThisWorkbook.Sheets("WH to FE").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2FE
ThisWorkbook.Sheets("Transfer").Activate
End If
If T2SC > 0 Then
ThisWorkbook.Sheets("WH to SC").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2SC
ThisWorkbook.Sheets("Transfer").Activate
End If
Next size1
Next r
ThisWorkbook.Sheets("WH to CH").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO CH - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
ActiveSheet.Cells.Interior.ColorIndex = xlNone
bottomrow = Selection.Rows.Count
For b = 3 To bottomrow Step 2
Range(Cells(b, 1), Cells(b, 28)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
'how do I add grid lines down?
End With
Next b
For c = 2 To 28
Range(Cells(1, c), Cells(bottomrow, c)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next c
'activate cell, change highlight, next cell
'.Rows(Target.Row).Interior.ColorIndex = HIGHLIGHT_COLOR
'ActiveSheet.Range("A" & b).Select
'.EntireRow.Interior.ColorIndex = 8
'Next b
End With
ThisWorkbook.Sheets("WH to DP").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO DP - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
End With
ThisWorkbook.Sheets("WH to FE").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO FE - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
End With
ThisWorkbook.Sheets("WH to SC").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO SC - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
End With
'freeze top row, add gridlines, highlight every other line, format to print,
' 5 - Identify the qty of each UPC from other stores that are required to get above MAQ
' 6 - Save the results as a new file
'Sheets(Array("Transfer", "Data", "WH to CH", "WH to DP", "WH to FE", "WH to SC")).Copy
'Set FFwb = ActiveWorkbook
'myCurrentDate = Year(Date) & "-" & Month(Date) & "-" & Day(Date)
'ClientCopyFileName = "Inventory Report - " & myCurrentDate
'SaveClientFile
'ThisWorkbook.Activate
'ActiveWorkbook.Sheets("Inventory Calculator").Activate
'ThisWorkbook.Sheets("Transfer").Visible = False ' rehide Transfer sheet
'ThisWorkbook.Sheets("Data").Visible = False ' rehide Data sheet
'FFwb.Activate
ActiveWorkbook.Sheets("Transfer").Activate
ActiveSheet.Range("A6").Select
Application.StatusBar = False ' turns off my custom status bar messages
Application.DisplayStatusBar = showStatusBar ' returns the status bar to its original state
Application.ScreenUpdating = True 'Re-enables the screen refreshing now that the macro is finished
End Sub
'Sub SaveClientFile()
' Dim Response, CloseFileName
' Dim SaveProblem, SameFileOpen As Boolean
' Dim w As Workbook
' SaveProblem = True
' Do
' Do
' ClientCopyFilePath = Application.GetSaveAsFilename(ClientCopyFileName, _
' FileFilter:="Microsoft Excel Workbook, *.xlsx")
'
' Loop Until ClientCopyFilePath <> False
' SameFileOpen = False
' If Len(Dir(ClientCopyFilePath)) <= 0 Then 'file does not exist
' ActiveWorkbook.SaveAs Filename:= _
' ClientCopyFilePath, FileFormat:= _
' xlWorkbookDefault
' SaveProblem = False
' Else: ' File Exists
' For Each w In Workbooks
' If w.FullName = ClientCopyFilePath Then
' SameFileOpen = True
' CloseFileName = w.Name
' End If
' Next
' If SameFileOpen = True Then ' A file with the same name is currently open
' Response = MsgBox("Another file with this name is currently open. Would you like to overwrite it?", vbYesNo)
' If Response = vbYes Then
' Application.DisplayAlerts = False
' Workbooks(CloseFileName).Close
' ActiveWorkbook.SaveAs Filename:=ClientCopyFilePath, FileFormat:=xlWorkbookDefault
' Application.DisplayAlerts = True
' SaveProblem = False
' Else:
' SaveProblem = True
' End If
' Else: ' The file of the same name is not currently open
' Response = MsgBox("A file with this name already exists. Would you like to overwrite it?", vbYesNo)
' If Response = vbYes Then
' Application.DisplayAlerts = False
' ActiveWorkbook.SaveAs Filename:= _
' ClientCopyFilePath, FileFormat:= _
' xlWorkbookDefault
' Application.DisplayAlerts = True
' SaveProblem = False
' Else
' SaveProblem = True
' End If
' End If
' End If
'
' Loop Until SaveProblem = False
'
'End Sub
Option Base 1
' Declaration of Variables
Public wbnames() As String
Public wbpath() As String
Public wsnames() As String
Public a, b, c, i, j, k, r, y, EPFileIndex, EPSheetIndex, bottomrow, TotalRows, MaxArray As Long
Public showStatusBar, myMatch As Boolean
Dim wb, EPwb, FFwb, w As Workbook
Dim WHmax, DesLen, lastrow4, addstorenum1, addstorenum2, addstorenum3, addstorenum4, addstorenum5, size1, lastrow2, lastrow3, UPC, Des, WHOH, CHOH, DPOH, FEOH, SCOH, CHmax, DPmax, FEmax, SCmax, T2CH, T2DP, T2FE, T2SC, CHdiff, DPdiff, FEdiff, SCdiff As Long
Dim ws, EPws As Worksheet
Dim InOpenBook
Dim fileToOpen
Dim myArray()
Public myCurrentDate, ClientCopyFileName As String
Dim ClientCopyFilePath
Sub Inventory()
' This macro performs the following functions
' 1 - Open existing Inventory Report
' 2 - Reformat report to give the count of each style per location
' 3 - Include MAX fill levels and Minimum Acceptable Quantity (MAQ) levels for each style by location
' 4 - Identify the qty of each UPC to fill from the warehouse to the individual stores
' 5 - Identify the qty of each UPC from other stores that are required to get above MAQ
' 6 - Save the results as a new file
'
'
'
'
'
'
'
'
'
Application.ScreenUpdating = False ' Turns off screen refreshing to speed up macro
showStatusBar = Application.DisplayStatusBar ' identify the current Status bar information
Application.DisplayStatusBar = True ' turn on the status bar
Application.StatusBar = "Please be patient..."
ThisWorkbook.Sheets("Transfer").Visible = True ' unhide Transfer worksheet
ThisWorkbook.Sheets("Data").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("Data2").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("Data3").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to FE").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("WH to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("CH to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("CH to FE").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("CH to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("DP to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("DP to FE").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("DP to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("FE to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("FE to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("FE to SC").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("SC to CH").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("SC to DP").Visible = True ' unhide Data worksheet
ThisWorkbook.Sheets("SC to FE").Visible = True ' unhide Data worksheet
' clear old data from the Data sheets
ThisWorkbook.Sheets("Data").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
'deletes the cells, rather than clearing them
ThisWorkbook.Sheets("Data2").Activate
Cells.Select
Selection.RemoveSubtotal
Selection.Clear
Range("A1").Select
ThisWorkbook.Sheets("Data3").Activate
Cells.Select
Selection.Clear
Range("A1").Select
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("Transfer").Activate
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to CH").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to DP").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to FE").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' clear old data from the Transfer sheet
ThisWorkbook.Sheets("WH to SC").Activate
ActiveSheet.Range("A2").Select
ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Clear
' 1 - Open existing Inventory Report
' Ask user if workbook with Inventory Report is currently open
InOpenBook = MsgBox("Is the Inventory Report currently open?", vbYesNo)
' If the user specifies that the Inventory data is in an open workbook, then
' compile a list of all open workbooks and prompts the user to choose which book contains the data
If InOpenBook = vbYes Then
' How many workbooks are currently open?
i = Workbooks.Count
' Redeclare arrays so that each array has exactly one entry for each open file
ReDim wbnames(i) As String
ReDim wbpaths(i) As String
j = 1
For Each wb In Workbooks
wbnames(j) = wb.Name
wbpaths(j) = wb.FullName
j = j + 1
Next wb
WorkbookChooser.Show
Set EPwb = Workbooks(wbnames(EPFileIndex))
EPwb.Activate
Else:
' If the user specifies that the inventory data is not in an open workbook, then
' prompt the user to find the file which contains the data. It then opens the selected file
If InOpenBook = vbNo Then
fileToOpen = Application.GetOpenFilename(FilterIndex:=56, _
MultiSelect:=False, Title:="Select Export Packages Report")
If fileToOpen <> False Then
' MsgBox fileToOpen
k = 0
For Each wb In Workbooks
If wb.FullName = fileToOpen Then
k = k + 1
Set EPwb = Workbooks(wb.Name)
End If
Next wb
If k = 0 Then
Workbooks.Open (fileToOpen)
Set EPwb = ActiveWorkbook
End If
EPwb.Activate
End If
Else:
' if the user quits then exit this macro
ThisWorkbook.Sheets("Transfer").Visible = False ' rehide Transfer sheet
ThisWorkbook.Sheets("Data").Visible = False ' rehide Data sheet
Application.StatusBar = False ' turns off my custom status bar messages
Application.DisplayStatusBar = showStatusBar ' returns the status bar to its original state
Application.ScreenUpdating = True 'Re-enables the screen refreshing now that the macro is finished
Exit Sub
End If
End If
Application.StatusBar = "Importing Inventory Data..."
' At this point, the Inventory report is open and active. Now we need to identify the sheet with the data.
' start by counting the number of sheets in the book
' if number of sheets = 1, then it should be obvious
' Otherwise, cycle through sheets and show user a dialog box to select the correct sheet
i = ActiveWorkbook.Worksheets.Count
ReDim wsnames(i) As String
If i = 1 Then
Set EPws = ActiveSheet
Else:
j = 1
For Each ws In Worksheets
wsnames(j) = ws.Name
j = j + 1
Next ws
WorksheetChooser.Show
Set EPws = Sheets(wsnames(EPSheetIndex))
End If
' Copy Raw Data from Inventory File into the formatter worksheet
EPws.Activate
ActiveSheet.Range("A1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
TotalRows = Selection.Rows.Count
ActiveSheet.Range(Cells(1, 1), Cells(TotalRows, 17)).Select
Selection.Copy Destination:=ThisWorkbook.Sheets("Data").Range("A1")
Application.CutCopyMode = False
If InOpenBook = vbNo Then EPwb.Close
ThisWorkbook.Sheets("Data").Activate
'added line below and changed two lines down to R from N
ActiveSheet.Range("Q1").Select
'ActiveSheet.Range("R1").Select
ActiveSheet.Range("r1:t1").Select
Selection.Copy
ActiveSheet.Range(Cells(2, 18), Cells(TotalRows, 20)).Select
Selection.PasteSpecial
Application.CutCopyMode = False
'paste into data2 for subtotals
ActiveSheet.Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Data2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Sort Key1:=Range("j1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=True, Orientation:=xlSortColumns
Columns("A:D").Select
Selection.Delete Shift:=xlRight
Columns("D:O").Select
Selection.Delete Shift:=xlRight
Columns("D:D").Select
Selection.Cut
Range("A1").Activate
Selection.Insert Shift:=xlRight
'make sure the sort is right so the vlookup works
'*************************************************
ActiveSheet.Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3, 4) _
, Replace:=True, PageBreaks:=False, SummaryBelowData:=False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:D").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Data3").Select
ActiveSheet.Paste
' 2 - Reformat report to give the count of each size of each style per location
Sheets("Data").Select
Range("m2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Transfer").Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'copy description down with store# added
Range("a6").Select
Range(Selection, Selection.End(xlDown)).Select
'ActiveWorkbook.Worksheets("Transfer").Sort.SortFields.Clear
'this step below might not work. might need to specify range differently.
ActiveWorkbook.Worksheets("Transfer").Sort.SortFields.Add Key:=Range( _
Selection, Selection.End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveSheet.Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow2 = Selection.Rows.Count
Range("A6").Select
y = 1
Do Until y = lastrow2
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
ActiveCell.Offset(5, 0).Select
y = y + 1
Loop
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow4 = Selection.Rows.Count
For y = 6 To lastrow4 + 5 Step 5
addstorenum1 = Cells(y, 1).Value
addstorenum1 = (addstorenum1 + "-257731")
ActiveSheet.Cells(y, 1).Value = addstorenum1
addstorenum2 = Cells(y + 1, 1).Value
addstorenum2 = (addstorenum2 + "-257732")
ActiveSheet.Cells(y + 1, 1).Value = addstorenum2
addstorenum3 = Cells(y + 2, 1).Value
addstorenum3 = (addstorenum3 + "-257733")
ActiveSheet.Cells(y + 2, 1).Value = addstorenum3
addstorenum4 = Cells(y + 3, 1).Value
addstorenum4 = (addstorenum4 + "-257734")
ActiveSheet.Cells(y + 3, 1).Value = addstorenum4
addstorenum5 = Cells(y + 4, 1).Value
addstorenum5 = (addstorenum5 + "-257735")
ActiveSheet.Cells(y + 4, 1).Value = addstorenum5
Next y
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
' Copy the Calculation Formulas down the transfer sheet
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow3 = Selection.Rows.Count
ActiveSheet.Range("b3:be3").Select
Selection.Copy
ActiveSheet.Range(Cells(6, 2), Cells(lastrow3 + 5, 57)).Select
Selection.PasteSpecial
Application.CutCopyMode = False
' 3 - Include MAX fill levels and Minimum Acceptable Quantity (MAQ) levels for each UPC by location
'3.1 this will come later...
' 4 - Identify the qty of each style to fill from the warehouse to the individual stores
ActiveSheet.Range("A6").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
lastrow3 = Selection.Rows.Count
For r = 6 To lastrow3 + 5 Step 5
For size1 = 2 To 28
Des = Cells(r, 1).Value
DesLen = Len(Des)
Des = Left(Des, DesLen - 7)
' capture des without store number.
SCOH = Cells(r, size1).Value
CHOH = Cells(r + 1, size1).Value
FEOH = Cells(r + 2, size1).Value
DPOH = Cells(r + 3, size1).Value
WHOH = Cells(r + 4, size1).Value
' how do i create the max table?
SCmax = Cells(r, size1 + 28).Value
CHmax = Cells(r + 1, size1 + 28).Value
FEmax = Cells(r + 2, size1 + 28).Value
DPmax = Cells(r + 3, size1 + 28).Value
WHmax = Cells(r + 4, size1 + 28).Value
T2CH = 0
T2DP = 0
T2FE = 0
T2SC = 0
Do Until WHOH = 0
CHdiff = CHmax - CHOH
DPdiff = DPmax - DPOH
FEdiff = FEmax - FEOH
SCdiff = SCmax - SCOH
If CHdiff > 0 Then
CHOH = CHOH + 1
T2CH = T2CH + 1
WHOH = WHOH - 1
End If
If WHOH = 0 Then Exit Do
If DPdiff > 0 Then
DPOH = DPOH + 1
T2DP = T2DP + 1
WHOH = WHOH - 1
If WHOH = 0 Then Exit Do
End If
If FEdiff > 0 Then
FEOH = FEOH + 1
T2FE = T2FE + 1
WHOH = WHOH - 1
If WHOH = 0 Then Exit Do
End If
If SCdiff > 0 Then
SCOH = SCOH + 1
T2SC = T2SC + 1
WHOH = WHOH - 1
If WHOH = 0 Then Exit Do
End If
If SCdiff <= 0 And CHdiff <= 0 And FEdiff <= 0 And DPdiff <= 0 Then WHOH = 0
Loop
'copy results of each upc to correct sheet
'can i remove the store number from the des to make it narrower?
If T2CH > 0 Then
ThisWorkbook.Sheets("WH to CH").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2CH
ThisWorkbook.Sheets("Transfer").Activate
End If
If T2DP > 0 Then
ThisWorkbook.Sheets("WH to DP").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2DP
ThisWorkbook.Sheets("Transfer").Activate
End If
If T2FE > 0 Then
ThisWorkbook.Sheets("WH to FE").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2FE
ThisWorkbook.Sheets("Transfer").Activate
End If
If T2SC > 0 Then
ThisWorkbook.Sheets("WH to SC").Activate
ActiveSheet.Cells(r - 4, 1).Value = Des
ActiveSheet.Cells(r - 4, size1).Value = T2SC
ThisWorkbook.Sheets("Transfer").Activate
End If
Next size1
Next r
ThisWorkbook.Sheets("WH to CH").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO CH - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
ActiveSheet.Cells.Interior.ColorIndex = xlNone
bottomrow = Selection.Rows.Count
For b = 3 To bottomrow Step 2
Range(Cells(b, 1), Cells(b, 28)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
'how do I add grid lines down?
End With
Next b
For c = 2 To 28
Range(Cells(1, c), Cells(bottomrow, c)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next c
'activate cell, change highlight, next cell
'.Rows(Target.Row).Interior.ColorIndex = HIGHLIGHT_COLOR
'ActiveSheet.Range("A" & b).Select
'.EntireRow.Interior.ColorIndex = 8
'Next b
End With
ThisWorkbook.Sheets("WH to DP").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO DP - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
End With
ThisWorkbook.Sheets("WH to FE").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO FE - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
End With
ThisWorkbook.Sheets("WH to SC").Activate
ActiveSheet.Cells(1, 1).Value = "WH TO SC - Description"
With ActiveSheet
For a = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(a)) = 0 Then
ActiveSheet.Rows(a).Delete
End If
Next a
End With
'freeze top row, add gridlines, highlight every other line, format to print,
' 5 - Identify the qty of each UPC from other stores that are required to get above MAQ
' 6 - Save the results as a new file
'Sheets(Array("Transfer", "Data", "WH to CH", "WH to DP", "WH to FE", "WH to SC")).Copy
'Set FFwb = ActiveWorkbook
'myCurrentDate = Year(Date) & "-" & Month(Date) & "-" & Day(Date)
'ClientCopyFileName = "Inventory Report - " & myCurrentDate
'SaveClientFile
'ThisWorkbook.Activate
'ActiveWorkbook.Sheets("Inventory Calculator").Activate
'ThisWorkbook.Sheets("Transfer").Visible = False ' rehide Transfer sheet
'ThisWorkbook.Sheets("Data").Visible = False ' rehide Data sheet
'FFwb.Activate
ActiveWorkbook.Sheets("Transfer").Activate
ActiveSheet.Range("A6").Select
Application.StatusBar = False ' turns off my custom status bar messages
Application.DisplayStatusBar = showStatusBar ' returns the status bar to its original state
Application.ScreenUpdating = True 'Re-enables the screen refreshing now that the macro is finished
End Sub
'Sub SaveClientFile()
' Dim Response, CloseFileName
' Dim SaveProblem, SameFileOpen As Boolean
' Dim w As Workbook
' SaveProblem = True
' Do
' Do
' ClientCopyFilePath = Application.GetSaveAsFilename(ClientCopyFileName, _
' FileFilter:="Microsoft Excel Workbook, *.xlsx")
'
' Loop Until ClientCopyFilePath <> False
' SameFileOpen = False
' If Len(Dir(ClientCopyFilePath)) <= 0 Then 'file does not exist
' ActiveWorkbook.SaveAs Filename:= _
' ClientCopyFilePath, FileFormat:= _
' xlWorkbookDefault
' SaveProblem = False
' Else: ' File Exists
' For Each w In Workbooks
' If w.FullName = ClientCopyFilePath Then
' SameFileOpen = True
' CloseFileName = w.Name
' End If
' Next
' If SameFileOpen = True Then ' A file with the same name is currently open
' Response = MsgBox("Another file with this name is currently open. Would you like to overwrite it?", vbYesNo)
' If Response = vbYes Then
' Application.DisplayAlerts = False
' Workbooks(CloseFileName).Close
' ActiveWorkbook.SaveAs Filename:=ClientCopyFilePath, FileFormat:=xlWorkbookDefault
' Application.DisplayAlerts = True
' SaveProblem = False
' Else:
' SaveProblem = True
' End If
' Else: ' The file of the same name is not currently open
' Response = MsgBox("A file with this name already exists. Would you like to overwrite it?", vbYesNo)
' If Response = vbYes Then
' Application.DisplayAlerts = False
' ActiveWorkbook.SaveAs Filename:= _
' ClientCopyFilePath, FileFormat:= _
' xlWorkbookDefault
' Application.DisplayAlerts = True
' SaveProblem = False
' Else
' SaveProblem = True
' End If
' End If
' End If
'
' Loop Until SaveProblem = False
'
'End Sub
