I have a macro which applies conditional formatting and filters. The macro should filter the file and save this out, it should then remove filters and filter again using different columns and save these results to another file. The macro is running but the files don't seem to be saving?
Code
Sub Customer_Connections()
'
' Macro1 Macro
'
Application.ScreenUpdating = False
' Email Must Be In Column F
'Duplicate Email
Columns("F:F").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$Z$999999").AutoFilter Field:=6, Criteria1:=RGB(255, _
199, 206), Operator:=xlFilterCellColor
ActiveWorkbook.SaveCopyAs ("Duplicate_Emails-" & Format(Now(), "ddmmyyyy") & ".xlsm")
'More Than One #
With Sheets("Customer Connections")
.Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Columns("G:G").NumberFormat = "General"
Cells.Select
Selection.AutoFilter
With .Range("G2:G" & .Range("A" & .Rows.Count).End(xlUp).Row)
.Formula = "=LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],""#"",""""))"
.Copy
.PasteSpecial xlPasteValues
End With
Range("G1").Select
ActiveCell.FormulaR1C1 = "Count Of #"
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$L$999999").AutoFilter Field:=7, Criteria1:="2"
End With
ActiveWorkbook.SaveCopyAs ("Two_#_In_Emails-" & Format(Now(), "mmddyyyy") & ".xlsm")
End Sub
Try this:
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & _
"\Two_#_In_Emails-" & Format(Now(), "mmddyyyy") & ".xlsm"
Related
Here is my code below that opens up yesterdays file Tuesday-Friday and the last 3 days on a Monday.
There is now a need to make a weekly version of this and i feel the code may get too long.
Is there a better way to do this then recreating the loop 7 times?
I am thinking i could do another loop that says that while column G (which only has information if updated in ) is empty then take the date in the respective cell in column A and keep opening files from the date in column A to yesterdays date? (pic for reference on what i mean) so it would fill every day from 13/09/2021 to 19/09/2021.
Also it would be nice if anyone had any pointers about making this code more robust and/or efficient as I am quite new to VBA.
Sub OpenManagersFileAndSelectColumns()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer, directory3day As String, fileName3day As String, directory2day As String, fileName2day As String, DateStringFS As String, AlteryxFP As String
' Turn off screen updating and displaying alerts.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Creating Dynamic Elements for directories and file names.
' Create the year, day amd month year
'For - 1 Days (used in two places)
YearString = Format((Date - 1), "yyyy")
MonthYearString = Format((Date - 1), "mmm yyyy")
DateString = Format((Date - 1), "dd-mm-yyyy")
'For - 2 Days
YearString2day = Format((Date - 2), "yyyy")
MonthYearString2day = Format((Date - 2), "mmm yyyy")
DateString2day = Format((Date - 2), "dd-mm-yyyy")
'For - 3 Days
YearString3day = Format((Date - 3), "yyyy")
MonthYearString3day = Format((Date - 3), "mmm yyyy")
Dim DateString3day As String
'Date for File Name
DateStringFS = Format((Date), "dd.mm.yy")
'Gets username of the device for comp and whether or not
comp = Environ("username")
'Gets Alteryx Output
If Environ("username") = "SP" Then
AlteryxFP = "Alteryx Output\"
Else
AlteryxFP = ""
End If
' Initialize the variable directory. We use the Dir function to find the first *.csv ?? file stored in this directory. ( this can be changed to xls if necessary
'For Today - 1 day (used in two places)
directory = "C:\Users\" & comp & "\Dropbox (SHG)\" & AlteryxFP & "\Daily Finance & Revenue Data\1. Daily Occupancy Output\Site 5\" & YearString & "\" & MonthYearString & "\" & DateString & "\"
'For Today - 2 Days
directory2day = "C:\Users\" & comp & "\Dropbox (SHG)\" & AlteryxFP & "\Daily Finance & Revenue Data\1. Daily Occupancy Output\Site 5\" & YearString2day & "\" & MonthYearString2day & "\" & DateString2day & "\"
'For Today - 3 Days
directory3day = "C:\Users\" & comp & "\Dropbox (SHG)\" & AlteryxFP & "\Daily Finance & Revenue Data\1. Daily Occupancy Output\Site 5\" & MonthYearString3day & "\" & DateString3day & "\"
'Ensures the current file is activated and clears previous content.
Windows("YORYK Daily Report " & DateStringFS & "$.xlsb").Activate
Sheets("Actual data").Activate
Rows("4:7").Select
Selection.ClearContents
'If its a monday then it will open the last 3 days, it is the rest of the week it will open the previous day.
If Format(Date, "w") = 2 Then
' Today - 1 days
fileName = Dir(directory & "*manager*.csv")
' The variable fileName now holds the name of the first Excel file found in the directory. Add a Do While Loop.
Do While fileName <> ""
' There is no simple way to copy worksheets from closed Excel files. Therefore we open the Excel file.
Workbooks.Open (directory & fileName), local:=True
' Import the sheets from the Excel file into import-sheet.xls.
For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("YORYK Daily Report " & DateStringFS & "$.xlsb").Worksheets.Count
Windows(fileName).Activate
' If the date in the file is TODAY -1 then accept, otherwise error message.
If Range("AG2") = (Date - 1) Then
Rows("2:2").Select
Selection.Copy
Windows("YORYK Daily Report " & DateStringFS & "$.xlsb").Activate
Sheets("Actual data").Activate
Rows("7:7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A4:AG5").Select
Application.CutCopyMode = False
Else
MsgBox "Date in file does not match " & DateString
' End If for checking the date for day - 1
End If
Next sheet
'Close the Excel file.
Workbooks(fileName).Close
'The Dir function is a special function. To get the other Excel files, you can use the Dir function again with no arguments.
fileName = Dir()
'Note: When no more file names match, the Dir function returns a zero-length string ("").
'As a result, Excel VBA will leave the Do While loop.
'End of loop for day - 1 file open and paste.
Loop
' Today - 2 days.
fileName2day = Dir(directory2day & "*manager*.csv")
' The variable fileName now holds the name of the first Excel file found in the directory. Add a Do While Loop.
Do While fileName2day <> ""
' There is no simple way to copy worksheets from closed Excel files. Therefore we open the Excel file.
Workbooks.Open (directory2day & fileName2day), local:=True
' Import the sheets from the Excel file into this sheet.
For Each sheet In Workbooks(fileName2day).Worksheets
total = Workbooks("YORYK Daily Report " & DateStringFS & "$.xlsb").Worksheets.Count
Windows(fileName2day).Activate
If Range("AG2") = Date - 2 Then
Rows("2:2").Select
Selection.Copy
Sheets("Actual data").Activate
Rows("6:6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
MsgBox "Date in file does not match " & DateString2day
End If
Next sheet
'Close the Excel file.
Workbooks(fileName2day).Close
'The Dir function is a special function. To get the other Excel files, you can use the Dir function again with no arguments.
fileName2day = Dir()
'Note: When no more file names match, the Dir function returns a zero-length string ("").
'As a result, Excel VBA will leave the Do While loop.
Loop
' Today - 3 days
fileName3day = Dir(directory3day & "*manager*.csv")
' The variable fileName now holds the name of the first Excel file found in the directory. Add a Do While Loop.
Do While fileName3day <> ""
' There is no simple way to copy worksheets from closed Excel files. Therefore we open the Excel file.
Workbooks.Open (directory3day & fileName3day), local:=True
' Import the sheets from the Excel file into import-sheet.xls.
For Each sheet In Workbooks(fileName3day).Worksheets
total = Workbooks("YORYK Daily Report " & DateStringFS & "$.xlsb").Worksheets.Count
Windows(fileName3day).Activate
'If Date in file is TODAY - 3 then accept and paste info otherwise error message.
If Range("AG2") = Date - 3 Then
Rows("1:2").Select
Selection.Copy
Windows("YORYK Daily Report " & DateStringFS & "$.xlsb").Activate
Sheets("Actual data").Activate
Rows("4:5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
MsgBox "Date in file does not match " & DateString3day
' End If for day - 3
End If
Next sheet
'Close the Excel file.
Workbooks(fileName3day).Close
'The Dir function is a special function. To get the other Excel files, you can use the Dir function again with no arguments.
fileName3day = Dir()
'Note: When no more file names match, the Dir function returns a zero-length string ("").
'As a result, Excel VBA will leave the Do While loop.
'End Loop for Today - 3
Loop
' End of loop, now cleaning data, for 3 days section
' Next step is to select the right columns of data and run calculations to get TR, RR, OCC, OOO, ADR for the 3 day period.
Range("A4:AF7").Select
Selection.delete Shift:=xlToLeft
Range("K4:AD7").Select
Selection.delete Shift:=xlToLeft
Range("AE4:DO7").Select
Selection.delete Shift:=xlToLeft
Range("AF4:AT7").Select
Selection.delete Shift:=xlToLeft
Range("AH4:CE7").Select
Selection.delete Shift:=xlToLeft
Columns("AE:AG").Select
Selection.Cut
Columns("C:C").Select
Selection.INSERT Shift:=xlToRight
Columns("F:M").Select
Selection.INSERT Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Windows("YORYK Daily Report " & DateStringFS & "$.xlsb").Activate
Sheets("Actual data").Activate
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Range("G4").Select
ActiveCell.FormulaR1C1 = "Rms"
Range("H4").Select
ActiveCell.FormulaR1C1 = "G Rms"
Range("I4").Select
ActiveCell.FormulaR1C1 = "Rm Rev"
Range("J4").Select
ActiveCell.FormulaR1C1 = "ADR"
Range("K4").Select
ActiveCell.FormulaR1C1 = "OOO Rms"
Range("L4").Select
ActiveCell.FormulaR1C1 = "Total Rev"
Range("G5").Select
ActiveCell.FormulaR1C1 = "=RC[-4]+RC[-3]"
Range("I5").Select
ActiveCell.FormulaR1C1 = "=RC[-7]-RC[13]"
Range("J5").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-3]"
Range("K5").Select
ActiveCell.FormulaR1C1 = "=RC[-6]"
Range("L5").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-10],RC[2]:RC[9])-SUM(RC[10]:RC[29])"
Range("G5:L5").Select
Selection.AutoFill Destination:=Range("G5:L7"), Type:=xlFillDefault
Range("G5:L7").Select
Range("G4").Select
' Colouring the titles to get notify it is done.
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Rms"
Range("H4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "G Rms"
Range("I4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Rm Rev"
Range("J4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "ADR"
Range("K4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "OOO Rms"
Range("L4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Total Rev"
Range("G4:L4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' This else is for days where day does not = monday, so any other day of the week.
Else
fileName = Dir(directory & "*manager*.csv")
' The variable fileName now holds the name of the first Excel file found in the directory. Add a Do While Loop.
Do While fileName <> ""
' There is no simple way to copy worksheets from closed Excel files. Therefore we open the Excel file.
Workbooks.Open (directory & fileName), local:=True
' Import the sheets from the forecast file into this sheet
For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("YORYK Daily Report " & DateStringFS & "$.xlsb").Worksheets.Count
Windows(fileName).Activate
If Range("AG2") = Date - 1 Then
Rows("1:2").Select
Selection.Copy
Windows("YORYK Daily Report " & DateStringFS & "$.xlsb").Activate
Sheets("Actual data").Activate
Rows("4:5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
MsgBox "Date in file does not match " & DateString
End If
Next sheet
'Close the Excel file.
Workbooks(fileName).Close
'The Dir function is a special function. To get the other Excel files, you can use the Dir function again with no arguments.
fileName = Dir()
'Note: When no more file names match, the Dir function returns a zero-length string ("").
'As a result, Excel VBA will leave the Do While loop.
Loop
' End of loop, for 1 day set up, now cleaning data
' Next step is to select the right columns of data and run calculations to get TR, RR, OCC, OOO, ADR for one day
Range("A4:AF7").Select
Selection.delete Shift:=xlToLeft
Range("K4:AD7").Select
Selection.delete Shift:=xlToLeft
Range("AE4:DO7").Select
Selection.delete Shift:=xlToLeft
Range("AF4:AT7").Select
Selection.delete Shift:=xlToLeft
Range("AH4:CE7").Select
Selection.delete Shift:=xlToLeft
Columns("AE:AG").Select
Selection.Cut
Columns("C:C").Select
Selection.INSERT Shift:=xlToRight
Columns("F:M").Select
Selection.INSERT Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Windows("YORYK Daily Report " & DateStringFS & "$.xlsb").Activate
Sheets("Actual data").Activate
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Range("G4").Select
ActiveCell.FormulaR1C1 = "Rms"
Range("H4").Select
ActiveCell.FormulaR1C1 = "G Rms"
Range("I4").Select
ActiveCell.FormulaR1C1 = "Rm Rev"
Range("J4").Select
ActiveCell.FormulaR1C1 = "ADR"
Range("K4").Select
ActiveCell.FormulaR1C1 = "OOO Rms"
Range("L4").Select
ActiveCell.FormulaR1C1 = "Total Rev"
Range("G5").Select
ActiveCell.FormulaR1C1 = "=RC[-4]+RC[-3]"
Range("I5").Select
ActiveCell.FormulaR1C1 = "=RC[-7]-RC[13]"
Range("J5").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-3]"
Range("K5").Select
ActiveCell.FormulaR1C1 = "=RC[-6]"
Range("L5").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-10],RC[2]:RC[9])-SUM(RC[10]:RC[29])"
'Colour titles for each title to mark that its done, for one day.
Range("G4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Rms"
Range("H4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "G Rms"
Range("I4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Rm Rev"
Range("J4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "ADR"
Range("K4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "OOO Rms"
Range("L4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Total Rev"
Range("G4:L4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' End If for -1 day vs - 3 day.
End If
'Turn on screen updating and displaying alerts again (outside the loop).
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The answer to your question is Yes, you should probably change your code to to work down the list of dates so that it is being driven by the data. In addition, your code could benefit a lot from better use of vba which you can learn:
As noted in comments, use variables in your vba code to give access workbooks, worksheets and cell ranges instead of using Activate and Select - which should be used only if you need to change what the user sees and, even then, only right at the end of your processing, just before giving control back to the user. Your code will be easier to read and run much faster.
Use named formatting styles instead of hard-coding styles. This is much more meaningful and is much easier to change and extend if you want to improve the appearance of your workbook without having to change the vba code.
Divide the code up into functions that do a specific parts of the logic, and call the functions instead of repeating the code. If you use variables to refer to workbooks, worksheets etc, then you can pass variables to the functions. For example, the code that processes one csv file could be written as a function that is called from higher-level logic.
I think you will find that your code becomes a lot simpler and easier to read and understand.
Please, try the next code. It is not tested, of course, but its logic should be correctly applied. It opens each csv file and copy its second row to the report starting from the 7th row, backwards to the first row:
Sub tes7DaysBackArray()
Dim arr7D, arrM, arrY, d As Date, DateStringFS As String, wsAD As Worksheet, wbLoc As Workbook, AlteryxFP As String
Dim pathRoot As String, fileName As String, comp As String, ws As Worksheet, i As Long, iRow As Long
DateStringFS = Format((Date), "dd.mm.yy"): d = Date: iRow = 7
'build arrays containing the necessary formatted strinns:
arr7D = Application.Transpose(Evaluate("TEXT(DATE(" & Year(d - 7) & "," & month(d - 7) & ",row(" & Day(d - 7) & ":" & Day(d - 1) & ")),""dd-mm-yyyy"")"))
arrM = Application.Transpose(Evaluate("TEXT(DATE(" & Year(d - 7) & "," & month(d - 7) & ",row(" & Day(d - 7) & ":" & Day(d - 1) & ")),""mmm yyy"")"))
arrY = Application.Transpose(Evaluate("TEXT(DATE(" & Year(d - 7) & "," & month(d - 7) & ",row(" & Day(d - 7) & ":" & Day(d - 1) & ")),""yyyy"")"))
Debug.Print Join(arr7D, "|"): Debug.Print Join(arrM, "|"): Debug.Print Join(arrY, "|") 'just to visually see the above built arrays...
If Environ("username") = "SP" Then
AlteryxFP = "Alteryx Output\"
Else
AlteryxFP = ""
End If
pathRoot = "C:\Users\" & comp & "\Dropbox (SHG)\" & AlteryxFP & "\Daily Finance & Revenue Data\1. Daily Occupancy Output\Site 5\"
Set wsAD = Workbooks("YORYK Daily Report " & DateStringFS & "$.xlsb").Sheets("Actual data")
For i = 0 To UBound(arr7D)
fileName = pathRoot & arrY(i) & "\" & arrM(i) & "\" & arr7D(i) & "\"
fileName = dir(fileName & "*manager*.csv")
If fileName <> "" Then
Set wbLoc = Workbooks.Open(Directory & fileName, local:=True)
Set ws = wbLoc.Sheets(1) 'the single existing sheet
If CStr(Format(ws.Range("AG2").Value, "dd-mm-yyyy")) = arr7D(i) Then
wsAD.rows(iRow & ":" & iRow).Value = ws.rows("2:2").Value: iRow = iRow + 1
wbLoc.Close False
Else
MsgBox "Date in file does not match " & arr7D(i)
End If
Else
MsgBox "No any required csv file could be found in & """ & fileName & """."
End If
Next i
End Sub
When I run my macro for the first time for the day it fails when it adds another sheet to the file.
Run-time error 1004: That name is already taken. Try a different
one.
My goal:
look for the file within \Downloads
convert the saved file it found from .xls -> .xlsx
delete the original downloaded file
run a bunch of formatting for printing.
When it fails, I close the current file, re-download the file, manually save the file with the needed format & name, delete the download, re-download the file.
After that I can run the macro.
The line that breaks: Sheets.Add(After:=Sheets("Dock Activity Report")).Name = "Cases"
Sub Schedule_macro()
Dim Filename, Pathname, SaveFileName As String
Dim wb As Workbook
Dim UserName As String
UserName = Environ("username")
Pathname = "C:\Users\" & Environ$("username") & "\Downloads\"
Filename = Dir(Pathname & "Dock_Activity_*.xls")
SaveFileName = Dir(Pathname & "dockactivity.xlsx")
Application.DisplayAlerts = False
If Len(Dir(Pathname & "Dock_Activity_*.xls")) > 0 Then
Debug.Print "Filename found, running macro"
Else
MsgBox "You need to download the" & vbNewLine & "Dock Activity Report from the" & vbNewLine & "'Report Run Log' in Lean." & vbNewLine & vbNewLine & "Once downloaded, please rerun the macro", vbCritical, "HiRise Schedule Macro"
Debug.Print "could not find Filename within given Pathname"
Debug.Print "exiting macro"
Exit Sub
End If
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
wb.CheckCompatibility = True
Application.DisplayAlerts = False
wb.SaveAs Filename:="dockactivity", FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
Filename = Dir(Pathname & "Dock_Activity_*.xls")
Filename = Dir()
Loop
Application.DisplayAlerts = True
If Dir(Pathname & "Dock_Activity_*.xls") <> "" Then
kill (Pathname & "Dock_Activity_*.xls")
End If
Debug.Print "looking for SaveFileName within given Pathname"
Set wb = Workbooks.Open(Pathname & "dockactivity.xlsx")
Debug.Print "SaveFileName found, opening file"
Windows("dockactivity.xlsx").Activate
Rows("1:21").Delete Shift:=xlUp
Range("A:B,D:F,H:N,S:S,U:V,X:Y,AB:AK,AM:BA").Delete Shift:=xlToLeft
Columns("H:H").Cut
Columns("A:A").Insert Shift:=xlToRight
Columns("K:K").Cut
Columns("G:G").Insert Shift:=xlToRight
Columns("J:K").Copy
Range("L1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("J:K").ClearContents
Range("J1").FormulaR1C1 = "Trailer Number"
Range("K1").FormulaR1C1 = "Arrival Time"
Columns("G:M").Copy
Range("N1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.ClearContents
Range("N1").FormulaR1C1 = "Door"
Range("O1").FormulaR1C1 = "Ship Rail"
Range("P1").FormulaR1C1 = "Staged"
Range("Q1").FormulaR1C1 = "Check If Loaded"
Range("R1").FormulaR1C1 = "Case Picks"
Range("S1").FormulaR1C1 = "Layer Picks"
Range("T1").FormulaR1C1 = "Check if Released by Pool"
Debug.Print "1:1 table headers complete"
Columns("A:B").ColumnWidth = 17.71
Columns("C:C").ColumnWidth = 19.14
Columns("D:D").ColumnWidth = 25.71
Columns("E:E").ColumnWidth = 14.41
Columns("F:F").ColumnWidth = 10.71
Columns("G:G").ColumnWidth = 30.29
Columns("H:H").ColumnWidth = 9.43
Columns("I:I").ColumnWidth = 13.71
Columns("J:J").ColumnWidth = 26.14
Columns("K:L").ColumnWidth = 23.57
Columns("M:M").ColumnWidth = 46
Columns("N:S").ColumnWidth = 15
Columns("T:T").ColumnWidth = 12.86
Debug.Print "column resizing complete"
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Rows("1:1").RowHeight = 75
Rows("2:150").RowHeight = 55
' #############################################################################
Sheets.Add(After:=Sheets("Dock Activity Report")).Name = "Cases"
Sheets.Add(After:=Sheets("Cases")).Name = "Layers"
' #############################################################################
Sheets("Dock Activity Report").Range("R2:R150").FormulaR1C1 = "=VLOOKUP(RC[-17],Cases!C[-13]:C[-12],2,FALSE)"
Sheets("Dock Activity Report").Range("S2:S150").FormulaR1C1 = "=VLOOKUP(RC[-18],Layers!C[-15]:C[-14],2,FALSE)"
Worksheets("Dock Activity Report").Select
Range("A2:T150").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=$C2=""Live Trailer"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Range("B2:B150").Select
ActiveWorkbook.Worksheets("Dock Activity Report").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Dock Activity Report").Sort.SortFields.Add Key:= _
Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Dock Activity Report").Sort
.SetRange Range("A1:T150")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Dock Activity Report").Select
Columns("A:A").Copy
Columns("B:B").Insert Shift:=xlToRight
Range("B2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IFERROR(RC[-1]*1,TRIM(RC[-1]))"
Range("B3").Select
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B150"), Type:=xlFillDefault
Range("B2:B150").Select
Columns("B:B").Copy
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Debug.Print "A:A value reformat complete"
Sheets("Dock Activity Report").Select
Columns("A:T").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTA($A1:$F1)>0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Borders
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
Selection.FormatConditions(1).StopIfTrue = False
Debug.Print "cell borders added"
Dim r As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For r = LastRow To 1 Step -1
If Cells(r, 1) = 0 Then
Rows(r).Delete
End If
Next r
Range("A1").Select
Sheets("Cases").Range("E2:E300").FormulaR1C1 = "=VALUE(TRIM(CLEAN(RC[-4])))"
Sheets("Cases").Range("F2:F300").FormulaR1C1 = "=RC[-2]"
Sheets("Cases").Columns("E:F").EntireColumn.Hidden = True
Sheets("Layers").Range("D2:D300").FormulaR1C1 = "=VALUE(TRIM(CLEAN(RC[-3])))"
Sheets("Layers").Range("E2:E300").FormulaR1C1 = "=RC[-2]"
Sheets("Layers").Columns("D:E").EntireColumn.Hidden = True
Sheets("Dock Activity Report").Range("A1").Select
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
MsgBox "All Finished!", vbInformation, "HiRise Schedule"
ActiveWorkbook.Save
End Sub
That is because there is already a sheet with that name.
Add this code and it will be ok.
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Cases").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add(After:=Sheets("Dock Activity Report")).Name = "Cases"
TIP: Avoid the use of .Select/Activate. Work with Objects. You may want to see How to avoid using Select in Excel VBA. It will be easy to manage the code as well.
I saved this file as a “Formatted Text (Space delimited)”. When I open it using excel the content in cell F7 is moved over to D7. Please see the attachment. Would I have to add “space saving” text to a7, b7, d7, & e7 or is there another way of doing this ?
Saved space delimited file:
enter image description here:
Sub Macro1()
'
' Main Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Range("C7").Select
ActiveCell.FormulaR1C1 = "ENTER_FAILURE"
Range("F7").Select
ActiveCell.FormulaR1C1 = "1"
Range("G7").Select
ActiveCell.FormulaR1C1 = "2"
Range("H7").Select
ActiveCell.FormulaR1C1 = "3"
Range("I7").Select
ActiveCell.FormulaR1C1 = "4"
Range("G7:I7").Select
Selection.AutoFill Destination:=Range("G7:O7"), Type:=xlFillDefault
Range("G7:O7").Select
Dim n As Integer
Dim colmm As Integer
Dim origFILEname As String: origFILEname = ActiveSheet.Name
Dim newName As String: newName = origFILEname & " + " & CStr(0)
Dim tstCaseCount As Double: tstCaseCount = 0
For colmm = 4 To 12 Step 1
' Copy orginal sheet and make copy active sheet
Call CopySheetAndRename(origFILEname, newName)
'innter loop will deal with inputting failures
For n = 36 To 56 Step 1
ActiveSheet.Cells(n, colmm) = 8888
Next n
'add code that save txt file here
SaveToRelativePath
'Increment test case count
tstCaseCount = tstCaseCount + 1
newName = origFILEnMAE & " + " & CStr(tstCaseCount)
Next colmm
End Sub
Sub CopySheetAndRename(xOrignalFileName As String, NwName As String)
'create a new sheet and rename it
Sheets(xOrignalFileName).Copy after:=Sheets(1)
On Error Resume Next
ActiveSheet.Name = NwName
End Sub
Sub SaveToRelativePath()
Dim relativePATH As String
'make failure red sub
MkFailureRed
'save ffile name as space delimited (*.prn) in the current folder
relativePATH = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".prn"
ActiveWorkbook.SaveAs Filename:=relativePATH, FileFormat:=xlTextPrinter, CreateBackup:=False
'save file name as workbook
relativePATH = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
ActiveWorkbook.SaveAs Filename:=relativePATH, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Sub MkFailureRed()
'add after to make index number red
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
'make all the failure red
ActiveWindow.SmallScroll down:=-3
Range("D12").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWindow.SmallScroll down:=-93
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=-50"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
I made a VBA macro that generates a MailMerge from an Excel spreadsheet creating the new document in Word.
I need to run a Find and Replace on a particular phrase ('ANTHXXXX') in the Word document with the user input variable InputtedModuleCode.
The macro runs without errors, but I can't get it to find and replace. I have included the entire macro script below. The relevant line of the script is underneath the comment:
' find and replace module code
...about 10 lines from the bottom of the script.
Sub AAMerge()
'
' AAMerge Macro
'
'
'Prompt user to input Module Code
Dim InputtedModuleCode As String
InputtedModuleCode = InputBox("Enter Module Code here, e.g. ANTH1001")
'Prompt user to input Module Code
Dim InputtedSubmissionDeadline As String
InputtedSubmissionDeadline = InputBox("Enter essay submission deadline. Must be format dd/mm/yyyy hh:mm:ss")
'Copy data into new spreadsheet
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 12
.StrikeThrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
With Selection.Font
.Name = "Arial"
.Size = 10
.StrikeThrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
' Move GradeMark Grade Column
Columns("H:H").Select
Selection.Copy
Columns("P:P").Select
ActiveSheet.Paste
' Delete Overlap/Internet Overlap/Publications Overlap/Student Papers Overlap columns
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("F:J").Select
Selection.Delete Shift:=xlToLeft
' insert Portico SCN formula
Range("F2").Select
ActiveCell.FormulaR1C1 = "SCN (Portico)"
Range("F3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-5],""_"",(LEFT(RC[-4],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,6,FALSE),"""")"
Range("F3").Select
Dim LR As Integer
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("F3").AutoFill Destination:=Range("F3:F" & LR), Type:=xlFillDefault
' insert Portico student email
Range("G2").Select
ActiveCell.FormulaR1C1 = "Email (Portico)"
Range("G3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-6],""_"",(LEFT(RC[-5],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,7,FALSE),"""")"
Range("G3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("G3").AutoFill Destination:=Range("G3:G" & LR), Type:=xlFillDefault
' insert Portico student department name
Range("H2").Select
ActiveCell.FormulaR1C1 = "Dept (Portico)"
Range("H3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-7],""_"",(LEFT(RC[-6],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,9,FALSE),"""")"
Range("H3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("H3").AutoFill Destination:=Range("H3:H" & LR), Type:=xlFillDefault
' Format column headers and widths
Rows("2:2").Select
Selection.Font.Bold = True
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
'Sort alphabetically by surname/firstname
Range("A3").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A3:A" & LR) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3:B" & LR) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:H" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Move SCN column from Column G to Column C
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut Destination:=Columns("C:C")
Columns("C:C").Select
' Remove ' at ' from Date Uploaded column
Columns("F").Replace What:=" at ", Replacement:=" ", LookAt:=xlPart
' Format date and add extra date columns
Columns("F:F").Select
Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("G2").Select
ActiveCell.FormulaR1C1 = "Extension Date"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Essay Deadline"
Columns("F:G").Select
Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
' Add user inputted submission date
Range("F3").Select
ActiveCell.FormulaR1C1 = CDate(InputtedSubmissionDeadline)
Range("F3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("F3").AutoFill Destination:=Range("F3:F" & LR), Type:=xlFillCopy
' Cleanup column width and add extra column
Columns("F:F").EntireColumn.AutoFit
Range("I2").Select
ActiveCell.FormulaR1C1 = "Days late"
Columns("J:J").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J2").Select
ActiveCell.FormulaR1C1 = "Penalty (%pts)"
' Number of days late column
Range("I3").Select
ActiveCell.FormulaR1C1 = _
"=IF((RC[-1]-(IF(RC[-2]=0,RC[-3],RC[-2]))<=0), 0, (ROUNDUP(RC[-1]-(IF(RC[-2]=0,RC[-3],RC[-2])),0)))"
Range("I3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("I3").AutoFill Destination:=Range("I3:I" & LR), Type:=xlFillDefault
' Penalty %pts column
Range("J3").Select
ActiveCell.FormulaR1C1 = _
"=(IF(RC[-1]>7,100,(IF(RC[-1]>1,10,IF(RC[-1]>0,5,0)))))"
Range("J3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("J3").AutoFill Destination:=Range("J3:J" & LR), Type:=xlFillDefault
' Add marks columns
Range("M2").Select
ActiveCell.FormulaR1C1 = "1stM Grade"
Range("N2").Select
ActiveCell.FormulaR1C1 = "2ndM Grade"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Final Grade"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Agreed Grade"
' Add final grade colum
Range("P2").Select
ActiveCell.FormulaR1C1 = "Final Grade (after penalty)"
Range("P3").Select
ActiveCell.FormulaR1C1 = "=MAX(0,(RC[-1]-RC[-6]))"
Range("P3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("P3").AutoFill Destination:=Range("P3:P" & LR), Type:=xlFillDefault
' Add column with formatted submission deadline date that can be read by MailMerge in word
Range("Q2").Select
ActiveCell.FormulaR1C1 = "Submission Deadline (formatted)"
Range("Q3").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-11],""dd-mmm-YYYY HH:mm:ss"")"
Range("Q3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("Q3").AutoFill Destination:=Range("Q3:Q" & LR), Type:=xlFillDefault
' Add column with formatted submission deadline date that can be read by MailMerge in word
Range("R2").Select
ActiveCell.FormulaR1C1 = "Date Uploaded (formatted)"
Range("R3").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-10], ""dd-mmm-YYYY HH:mm:ss"")"
Range("R3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("R3").AutoFill Destination:=Range("R3:R" & LR), Type:=xlFillDefault
'Save file
ActiveWorkbook.SaveAs Filename:="N:\EssaySubTrial\" & InputtedModuleCode & " Datasheet " & _
Format(Now(), "yyyy-mm-dd HHmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Sheet3").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet2").Select
ActiveWindow.SelectedSheets.Delete
' do Mailmerge
Dim wdOutputName, wdInputName As String
wdOutputName = ThisWorkbook.Path & "\Coversheet " & Format(Date, "d mmm yyyy")
wdInputName = ThisWorkbook.Path & "\coursework-coversheet-template-merged-updated.docx"
' open the mail merge layout file
Dim wdDoc As Object
Set wdDoc = GetObject(wdInputName, "Word.document")
wdDoc.Application.Visible = True
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With
' find and replace module code
wdDoc.Application.ActiveDocument.Content.Find.Execute "ANTHXXXX", ReplaceWith:=InputtedModuleCode, Replace:=wdReplaceAll
' show and save output file
wdDoc.Application.Visible = True
wdDoc.Application.ActiveDocument.SaveAs wdOutputName
' cleanup
wdDoc.Close SaveChanges:=False
Set wdDoc = Nothing
End Sub
I haven't check the remainder of the code but if your problem is merely the Find and replace at the bottom of the code then the following should do the job (setting the replacement from a string shouldn't matter):
'I'd recommend leaving all these options in
With wdDoc.Application.Selection.Find
.ClearFormatting
.Text = "ANTHXXXX"
.Replacement.Text = InputtedModuleCode
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
One other thing if you're interested, the code wdDoc.Application.ActiveDocument.SaveAs does exactly the same thing as wdDoc.SaveAs.
I have an existing .xlsm file that runs perfectly with all of the macros. The problem is that when I attempt to record another macro, I add a column, press enter, and get the message "Microsoft Excel has stopped responding". I then have to end the process. I am assuming that this has something to do with the existing macro which was imported from Excel 2003 and modified to work for 2010.
Are there any incompatabilities within this macro that could cause this issue?
Sub Auto_Open()
Wbname = ActiveWorkbook.Name ' this needs to be first so the move works properly
fileToOpen = Application.GetOpenFilename("CSV files (*.csv), *.csv", 1, "Select file to open")
If fileToOpen <> False Then
Workbooks.Open (fileToOpen)
End If
sheetname = ActiveSheet.Name
Sheets(sheetname).Select
Sheets(sheetname).Move Before:=Workbooks(Wbname).Sheets(1)
Call Weekly_RTP
End Sub
Sub Weekly_RTP()
'
' Macro recorded 01/12/12 by Robert Gagliardi
'
' This next section (up to call sort_data) is needed until we get the formatting correct.
' Clearing the last rows and adding misc headers will solve the short term problem
' Need this once pivot table is created. Can't have heading row without names in it
Range("L1").Select
ActiveCell.FormulaR1C1 = "Misc"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Misc1"
Columns("N:Z").Select
Selection.ClearContents
Call Sort_data
' concat mui & object to make it easy to find dups use countifs once at excel 2007 or greater
Range("N1").Select
ActiveCell.FormulaR1C1 = "Junk"
Range("N2").Select
ActiveCell.FormulaR1C1 = "=RC[-7]&RC[-5]"
Range("N2").Select
Selection.Copy
' need to find last row using column K2
lastrow = ActiveSheet.Range("K2").End(xlDown).Select
' Selection.Offset(0, 3).Select Moves over 3 cells
Range("N2", Selection.Offset(0, 3)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Range("C1").Select
ActiveCell.FormulaR1C1 = "Alerts"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(COUNTIF(R2C[12]:RC15,RC[12])=1,COUNTIF(C[12],RC[12]),"" "")"
Range("C2").Select
Selection.Copy
' need to find last row using column B2 since column C was just added
lastrow = ActiveSheet.Range("B2").End(xlDown).Select
' Selection.Offset(0, 1).Select Moves over 1 cell from last cell in column B
Range("C2", Selection.Offset(0, 1)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Call Create_pivot
Call Save_data
' how to select a range of cells with data in them
' Worksheets(ActiveSheet.Name).Activate
' ActiveCell.CurrentRegion.Select
End Sub
Sub Create_pivot()
Wbname = ActiveWorkbook.Name
' Insert columns to make room for pivot table
Columns("A:I").Select
Selection.Insert Shift:=xlToRight
myData = Sheets(ActiveSheet.Name).[J1].CurrentRegion.Address
mySheet = ActiveSheet.Name & "!"
tableDest = "[" & Wbname & "]" & mySheet & "R1C1"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
mySheet & myData).CreatePivotTable TableDestination:=tableDest, TableName _
:="RTP_alerts", DefaultVersion:=xlPivotTableVersionCurrent
With ActiveSheet.PivotTables("RTP_alerts").PivotFields("Application")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("RTP_alerts").PivotFields("Object")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("RTP_alerts").AddDataField ActiveSheet.PivotTables( _
"RTP_alerts").PivotFields("Alerts"), "Count of Alerts", xlCount
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
Columns("G:I").Select
Selection.Delete Shift:=xlToLeft
Range("D2").Select
ActiveCell.FormulaR1C1 = "Owner"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Problem Ticket"
Columns("E:E").ColumnWidth = 13
Range("F2").Select
ActiveCell.FormulaR1C1 = "Comments"
Columns("F:F").ColumnWidth = 48
End Sub
Sub Save_data()
Filename = ActiveWorkbook.Name
Do
Fname = Application.GetSaveAsFilename(Filename, fileFilter:="Excel Files (*.xlsm), *.xlsm")
Loop Until Fname <> False
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=52
End Sub
Sub Sort_data()
Columns("A:M").Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Range("A1").Select
End Sub
I experienced the same problem, here's something you can try. Go to start-->run, and type %temp% in the box. This will bring up your temporary files.
Delete all or some of them, restart your computer and try again.