Dim TheFIleName As String
Dim TheFilePathMaster As String
Dim TheFilePath As String
Dim TheSDWFile1 As String
Dim TheSDWSheet1 As String
Sub DeclareVar()
' TheFileName is the name of the Master file that will be updated
' TheFilePathMaster is the file Path of where the master file is located
TheFIleName = "Case Sales Report Hilo.xlsm"
TheFilePathMaster = "L:\Accounting\Emp - Carol\Unit Sales\Hilo Cases Sale Report\"
' TheFilePath is where the Export data file from SDW is located
TheFilePath = "L:\Accounting\Emp - Carol\SDW Download\"
' TheSDWFileX is the name of the SDW exported file
' TheSDWSheetX is the name of the excel sheet name where the above is to be copied to
TheSDWFile1 = "Weekly Hilo Case Sales.xls"
TheSDWSheet1 = "Hilo 8 weeks average"
End Sub
Sub Reposition_to_MainSheet()
'
' Reposition_to_Date to TOC sheet
' note:
'
Sheets("Hilo 8 weeks average").Select
Cells(3, 3).Select
End Sub
Sub SDWAllGetData()
'
' SDWGetData Macro
' To run all the Get data sub routine
'
Call SDW1GetData
Call Formatsheets
Call UpdAvgWk
Call Reposition_to_MainSheet
Call Allpau
End Sub
Sub SDW1GetData()
'
' SDWGetData Macro
'
'
Call DeclareVar
Workbooks.OpenText Filename:=TheFilePath & TheSDWFile1 _
, Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
Cells.Select
Selection.Copy
Windows(TheFIleName).Activate
Sheets(TheSDWSheet1).Select
Range("A1").Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False
Windows(TheSDWFile1).Close
Windows(TheFIleName).Activate
End Sub
Sub Formatsheets()
Call DeclareVar
' format the SDW imported sheets
Dim WSD As Worksheet
Set WSD = Worksheets(TheSDWSheet1)
' WSD.Rows("4:5").HorizontalAlignment = xlCenter
' WSD.Rows("4:5").WrapText = True
' WSD.Columns.ColumnWidth = 13
' WSD.Columns("A:C").ColumnWidth = 4
Dim rng As Range
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
'Set Rng = Cells(12, 8).Resize(Finalrow - 11, 1)
Rows("1:6").Select
Selection.Delete Shift:=xlUp
Rows("1:2").Select
Selection.Font.Bold = True
Range("N1").Select
Columns("A:M").EntireColumn.AutoFit
End Sub
Sub UpdAvgWk()
'
'
Call DeclareVar
Sheets(TheSDWSheet1).Select
' give the header name description as in cell AO1 to AT1
Range("n1").Select
ActiveCell.FormulaR1C1 = "Average 8 Week"
Dim rng As Range
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
' set range to update row
Set rng = Cells(3, 14).Resize(finalrow - 2, 1)
rng.FormulaR1C1 = "=AVERAGE(RC[-8]:RC[-1])"
rng.NumberFormat = "#,##0_);[Red](#,##0)"
Range("N1").Columns.AutoFit
End Sub
Sub UpdMassDataPull1()
'
' Update MassDataPull1
' update column H of DFC Key for any account label as "Other" to use table in Channel Lookup
'
Sheets(TheSDWSheet8).Select
' select row ten and copy and paste it to row 11 for table headers to move field name for Pivot table data source
Rows("10:10").Select
Selection.Copy
Rows("11:11").Select
ActiveSheet.Paste
'or can use this code select row ten and copy and paste it to row 11 for table headers to move field name for Pivot table data source
Rows("6:6").Insert
Rows("8:8").Copy
Rows("6:6").Select
ActiveSheet.Paste
Rows("8:8").Delete
' on column H - DFC Key select filter and select "other" only
Dim rng As Range
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Cells(12, 8).Resize(finalrow - 11, 1)
' select only rows with "OTHER"
Cells(11, 1).AutoFilter Field:=8, Criteria1:="OTHER"
' then for the other change th DFC KEy act to the Vlookup table from the Channel Lookup sheets
' range b56 to C62
' select only visible cells in range rng and replace with vlookup formula from
rng.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=+VLOOKUP(RC6,'Channel Lookup'!R56C2:R62C3,2,0)"
'Show all data
ActiveSheet.ShowAllData
' select finalrow where totals should be and delete - as pivot table does not need total row
' note may need to delete 11 additional row
Cells(finalrow, 1).EntireRow.Delete
End Sub
Sub UpdSalesReturns5()
'
' UpdSalesReturns5 update Sales Return sheet to add subtotal by salesman name
'
Sheets(TheSDWSheet5).Select
Dim rng As Range
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
FinalCol = Cells(7, Columns.Count).End(xlToLeft).Column
Set rng = Cells(7, 1).Resize(finalrow - 7, FinalCol)
'
rng.Select
Selection.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 6, 7, 8, _
9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28), Replace:=True, _
PageBreaks:=False, SummaryBelowData:=True
End Sub
Sub SaveReport()
' Macro to allow to
' Save the file
Filename = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx), *.xlsm, *.xls")
MsgBox "You selected " & Filename
Stop
If Filename = False Then
Else
ActiveWorkbook.SaveAs Filename:=Filename
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Sub Zip_ActiveWorkbook()
'Zip the ActiveWorkbook
'This sub will make a copy of the Activeworkbook and zip it in "C:\Users\test\" with a date-time stamp.
'Change this folder or use your default path Application.DefaultFilePath
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
Dim FileExtStr As String
DefPath = "L:\Sales&Marketing\Volume&Margin\PCGReports\" '<< Change
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xl* and Zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
Else
Select Case ActiveWorkbook.FileFormat
Case 51: FileExtStr = ".xlsx"
Case 52: FileExtStr = ".xlsm"
Case 56: FileExtStr = ".xls"
Case 50: FileExtStr = ".xlsb"
Case Else: FileExtStr = "notknown"
End Select
If FileExtStr = "notknown" Then
MsgBox "Sorry unknown file format"
Exit Sub
End If
End If
strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
' FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr))& strDate & ".zip"
FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr
'If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNameXls
MsgBox "Your Backup is saved here: " & FileNameZip
'Else
' MsgBox "FileNameZip or/and FileNameXls exist"
'End If
End Sub
Sub GetAROpendata()
'
' GetAROpenData Macro to get ARopen detail
'
'
' open workbook
Workbooks.Open Filename:="L:\Shared\DMS Reports\AR Open item by Salesman.xls"
' select sheet of all open invoices
Sheets("AROpen").Select
' Turn off all filter to show all data
ActiveSheet.ShowAllData
' find final row
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
'Select range A1 to Kfinalrow and select only record with bill to # 1083349,1083370 and 1085069
ActiveSheet.Range("A1:K" & finalrow).AutoFilter Field:=2, Criteria1:=Array( _
"1083349", "1083370", "1085069"), Operator:=xlFilterValues
' select and copy all records
Cells.Select
Selection.Copy
' go back to master sheet and paste into sheet OpenATB
Windows("_KeyPunch1_ARCreateChecksInvoiceDetailFoodland.xls").Activate
Sheets("OpenATB").Select
Cells.Select
ActiveSheet.Paste
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks