Option Explicit 'Tools | Options | Require Variable Declarations will automatically add this to all new modules
Sub KP()
'
' KP Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
'I always declare variables - it has saved me a lot of time over the years
Dim SaveToDirectory As String
Dim lLastDataRow As Long
Dim sSaveLocation As String
Dim File_Name As String
Dim sDateString As String
'I also use prefixes to distinguish the variable type, some folks do not
' this is an article the discusses pros and cons for 'Hungarian notation'
'https://softwareengineering.stackexchange.com/questions/39771
ActiveSheet.Name = "sheet1"
SaveToDirectory = "G:\ "
'Most things do not have to be selected to be acted upon (some graph elements are an exception)
'Replace next 2 lines with 3rd
' Cells.Select
' Selection.Columns.AutoFit
Cells.Columns.AutoFit
With ActiveSheet
.AutoFilterMode = False 'To make sure the sheet was not left in a filtered state
.Range("A1").CurrentRegion.RemoveDuplicates Columns:=4, Header:=xlYes
End With
'Using the With statement and objects starting with a . to reference the with statement
' processes more quickly. Not significant for a single pass, but can be very important
' inside a processing loop
With ActiveWorkbook.Worksheets("sheet1")
lLastDataRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find the last row with data in column 1 (A)
.Sort.SortFields.Clear
'Changed the last row from a fixed number to the actual last row
.Sort.SortFields.Add Key:=Range("E2:E" & lLastDataRow), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange ActiveWorkbook.Worksheets("sheet1").Range("A1:G" & lLastDataRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Columns("F:F").Select
' Selection.Style = "Currency"
.Columns("F:F").Style = "Currency"
'Next few rows is a bit confusing, unless you have filtered the data and are doing something
' with the visible cells
' Range("F3").Select 'This will select F3
' Selection.End(xlDown).Select 'This will select the cell above the next blank cell in column F
' Cells.SpecialCells(xlCellTypeVisible)(1).Select 'This will select A1
'Not sure what you are trying to do here, but here are some possibilities
'This will select all visible cells in column F from F3 down
.Range(.Range("F3"), .Cells(.Rows.Count, 6).End(xlUp)).SpecialCells(xlCellTypeVisible).Select
'But if it is a 'normal' data set with the all used columns for all used rows having some
' this will also work to select all visible cells in column F from F3 down
.Range("F3:F" & lLastDataRow).Select
'What is the intent behind this line?
.Cells.SpecialCells(xlCellTypeVisible)(1).Select
' SetCurrentDirectoryA "\\server\share\share folders\Reports "
' ChDrive "G:\" 'To set the default drive (only first letter is read)
' ChDir "G:\" 'To set the default folder on that drive
' wb = Application.Dialogs(xlDialogSaveAs).Show(File_Name, 51)
'MsgBox CurDir 'Show the current drive:\folderpath
'sSaveLocation = "G:\”
'I am not sure if your date is in a YMD format, but that format makes it easier to sort.
'Also ISO 8601 (see Wikipedia) and I both like yyyy-mm-dd for a standard date format.
sDateString = Format(Now(), "yy-mm-dd")
File_Name = InputBox("Enter the save filename format must be 'date 00-00-00 Report'", "Enter Filename", _
"date " & sDateString & " Report")
sSaveLocation = "\\server\share\share folders\Reports\"
' File_Name = InputBox("Enter the save filename for the workbook in P", "Enter Filename")
If Len(File_Name) > 0 Then
'ThisWorkbook.SaveAs (sSaveLocation & File_Name & ".xlsx")
'ActiveWorkbook.SaveAs fileName:=fileName 'default ext
ActiveWorkbook.SaveAs (sSaveLocation & File_Name & ".xlsx")
'ActiveWorkbook.SaveAs fileName:=SaveToDirectory & File_Name & ".xlsx", FileFormat:=51
Else
MsgBox "No filename entered. Edited workbook not saved.", vbCritical, "No Filename Entered"
End If
End With
End Sub
