Hey everyone,
I am stuck on a problem with a workbook and can't seem to find any answers online. I'm running a set of macros in the workbook to upload data from some text files and alter the formatting. In doing so I am turning off screen updating at the beginning of the series of macros and then turning screen updating back on at the end. This is working great. The problem I am encountering is after the macros have been run some of the buttons in the ribbon menu are not functioning properly. For example any of the buttons with dropdowns (i.e. color fill, borders, macros, etc) will not allow me to select from the dropdown menu. In addition some functions appear to be delayed. For example when I try click to filter, the dropdowns for filtering on the header columns don't appear until selecting a couple of new cells. Very strange behavior that makes the workbook difficult to use.
When I was trying to resolve the issue, I found that if I close the workbook and re-open it, the excel goes back to functioning normally (that is until I run the macros again). Also, I found that if I remove the screen updating sections of my vba code, then excel works fine after the macros are run.
I need to be able to run the macros without screen updating. Any help or information anyone could provide would be greatly appreciated. Code for macros is posted below. Run() (at the bottom of the posted code) is the macro I am running that causes the issue. Also I am running these macros from ActiveX buttons within the spreadsheet (in case that is relevant).
I am stuck on a problem with a workbook and can't seem to find any answers online. I'm running a set of macros in the workbook to upload data from some text files and alter the formatting. In doing so I am turning off screen updating at the beginning of the series of macros and then turning screen updating back on at the end. This is working great. The problem I am encountering is after the macros have been run some of the buttons in the ribbon menu are not functioning properly. For example any of the buttons with dropdowns (i.e. color fill, borders, macros, etc) will not allow me to select from the dropdown menu. In addition some functions appear to be delayed. For example when I try click to filter, the dropdowns for filtering on the header columns don't appear until selecting a couple of new cells. Very strange behavior that makes the workbook difficult to use.
When I was trying to resolve the issue, I found that if I close the workbook and re-open it, the excel goes back to functioning normally (that is until I run the macros again). Also, I found that if I remove the screen updating sections of my vba code, then excel works fine after the macros are run.
I need to be able to run the macros without screen updating. Any help or information anyone could provide would be greatly appreciated. Code for macros is posted below. Run() (at the bottom of the posted code) is the macro I am running that causes the issue. Also I am running these macros from ActiveX buttons within the spreadsheet (in case that is relevant).
Code:
Sub UploadFile(cell)
'
'UploadFile Macro
'-Displays file browser and puts selected file path into 'cell'
Dim fileStr As String
'get file path from user (from browser)
fileStr = Application.GetOpenFilename(Title:="File Upload")
If fileStr = "False" Then Exit Sub
'put file path in 'cell'
cell.Value = fileStr
End Sub
Sub Import_RGIS_SCANNED()
'
' Import_RGIS_SCANNED Macro
'-Imports RGIS Scanned Files that have been selected by user to upload
'
'
Sheets("ORIGINAL").Select
Dim startRow As Integer
startRow = 7
Dim i As Integer
Dim nRow As Integer
'loop for number of files given by user
For i = 2 To (2 * Sheets("Instructions").Range("$B$" & startRow).Value) Step 2
'import file designated by path
Path = Sheets("Instructions").Cells((startRow + i), 3).Text
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Path _
, Destination:=Selection)
.Name = "RGIS_REPORT"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'if the file is not the first file to be uploaded -> remove the header
If i > 2 Then
Rows(Selection.Row).Delete
End If
'select the first cell of the row right after the data has been input
'(where next file, if there is one, will upload to)
nRow = Sheets("ORIGINAL").UsedRange.Rows.Count + 1
Sheets("ORIGINAL").Range("A" & nRow).Select
Next
Sheets("ORIGINAL").Select
End Sub
Sub ClearAll()
'
' ClearAll Macro
'-Clears all sheets by deleting each sheet and creating a new one with the same name
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("ORIGINAL").Delete
Dim Sheet1 As Worksheet
Set Sheet1 = Sheets.Add(After:=Worksheets(Worksheets.Count))
Sheet1.Name = "ORIGINAL"
Sheets("DUPLICATES").Delete
Dim Sheet2 As Worksheet
Set Sheet2 = Sheets.Add(After:=Worksheets(Worksheets.Count))
Sheet2.Name = "DUPLICATES"
Sheets("UNEXPECTED COST CENTERS").Delete
Dim Sheet3 As Worksheet
Set Sheet3 = Sheets.Add(After:=Worksheets(Worksheets.Count))
Sheet3.Name = "UNEXPECTED COST CENTERS"
Sheets("WITHOUT DUPLICATES").Delete
Dim Sheet4 As Worksheet
Set Sheet4 = Sheets.Add(After:=Worksheets(Worksheets.Count))
Sheet4.Name = "WITHOUT DUPLICATES"
Sheets("Instructions").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub ClearFilePaths()
'Clear FilePaths on 'Instruction' Sheet
Sheets("Instructions").Select
Range("C9", "C17").Select
Selection.ClearContents
Range("B7").Value = "1"
Range("A1").Select
End Sub
Sub Format()
'
' Format Macro
'-Formats 'ORIGINAL' Sheet
'
'Format Header
Sheets("ORIGINAL").Select
Range("A1:M1").Select
With Selection
.WrapText = True
.Font.Bold = True
.Borders(xlEdgeBottom).Weight = xlMedium
End With
'Center All Columns and adjust volumn widths
Columns("A:M").HorizontalAlignment = xlCenter
Columns("A:M").AutoFit
Columns("A:C").ColumnWidth = 8.5
Columns("J:N").ColumnWidth = 8.5
'Adjust Number formats for CCs, Room #s, and building #s, and asset id #s
Columns("A:A").Select
Selection.NumberFormat = "0000"
Columns("B:B").Select
Selection.NumberFormat = "00"
Columns("C:C").Select
Selection.NumberFormat = "000"
Columns("D:D").Select
Selection.NumberFormat = "00000000"
Columns("J:J").Select
Selection.NumberFormat = "0000"
Columns("K:K").Select
Selection.NumberFormat = "00"
Columns("L:L").Select
Selection.NumberFormat = "000"
'Sort by Asset ID
Range("A1:M10000").Select
ActiveWorkbook.Worksheets("ORIGINAL").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ORIGINAL").Sort.SortFields.Add Key:= _
Range("D2:D10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("ORIGINAL").Sort
.SetRange Range("A1:M10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub
Sub Unexpected_Cost_Centers()
'
' Unexpected_Cost_Centers Macro
'-Generate 'Unexpected COST CENTERS' Sheet
'
'Copy header to 'UNEXPECTED COST CENTERS'
Sheets("ORIGINAL").Select
Range("A1:M1").Copy
Sheets("UNEXPECTED COST CENTERS").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths
ActiveSheet.Paste
'Add Column for Force Transfer status
Range("N1").Select
ActiveCell.FormulaR1C1 = "Force Transfer"
With Selection
.WrapText = True
.Font.Bold = True
.Borders(xlEdgeBottom).Weight = xlMedium
End With
Columns("N:N").HorizontalAlignment = xlCenter
'Loop over each asset on 'ORIGINAL SHEET'
Sheets("ORIGINAL").Select
Dim lRow As Long
Dim iCntr As Long
Dim r As Integer
lRow = ActiveSheet.UsedRange.Rows.Count
For iCntr = lRow To 2 Step -1
'Check if asset was expected to be found a different location
If ((Not IsEmpty(Cells(iCntr, 10))) And (Not (Cells(iCntr, 10) = Cells(iCntr, 1)))) Then
'Highlight asset in green
Range(Cells(iCntr, 1), Cells(iCntr, 13)).Interior.ColorIndex = 43
'Move copy of assets from other cost centers to 'UNEXPECTED COST CENTERS' SHEET
Range(Cells(iCntr, 1), Cells(iCntr, 13)).Copy
Sheets("UNEXPECTED COST CENTERS").Select
r = ActiveSheet.UsedRange.Rows.Count + 1
Cells(r, 1).Select
ActiveSheet.Paste
'Highlight force transfer cell in yellow
Cells(r, 14).Interior.ColorIndex = 6
Sheets("ORIGINAL").Select
End If
Next
'Sort 'UNEXPECTED COST CENTERS' assets by asset ID
Sheets("UNEXPECTED COST CENTERS").Select
Range("A1:N10000").Select
ActiveWorkbook.Worksheets("UNEXPECTED COST CENTERS").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("UNEXPECTED COST CENTERS").Sort.SortFields.Add Key:= _
Range("D2:D10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("UNEXPECTED COST CENTERS").Sort
.SetRange Range("A1:N10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Sheets("ORIGINAL").Select
Range("A1").Select
End Sub
Sub Duplicates()
'
' Duplicates Macro
'-Finds Duplicates, Generates 'DUPLICATES' and 'WITHOUT DUPLICATES' sheets
'Copy Header to 'DUPLICATES' and 'WITHOUT DUPLICATES' sheets
Sheets("ORIGINAL").Select
Range("A1:M1").Copy
Sheets("WITHOUT DUPLICATES").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths
ActiveSheet.Paste
Sheets("DUPLICATES").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths
ActiveSheet.Paste
'Loop over each asset on 'ORIGINAL SHEET'
Sheets("ORIGINAL").Select
Dim lRow As Long
Dim iCntr As Long
Dim r As Integer
lRow = ActiveSheet.UsedRange.Rows.Count
For iCntr = lRow To 2 Step -1
'Check if asset is a duplicate on the list
If (Cells(iCntr, 4) = Cells((iCntr - 1), 4)) Then
'Highlight asset in red
Range(Cells(iCntr, 1), Cells(iCntr, 13)).Interior.ColorIndex = 3
'Move copy of Duplicate Assets to 'DUPLICATES' SHEET
Range(Cells(iCntr, 1), Cells(iCntr, 13)).Copy
Sheets("DUPLICATES").Select
r = ActiveSheet.UsedRange.Rows.Count + 1
Cells(r, 1).Select
ActiveSheet.Paste
Sheets("ORIGINAL").Select
'If asset is not a duplicate
Else
'Move copy of asset to 'WITHOUT DUPLICATES' SHEET
Range(Cells(iCntr, 1), Cells(iCntr, 13)).Copy
Sheets("WITHOUT DUPLICATES").Select
r = ActiveSheet.UsedRange.Rows.Count + 1
Cells(r, 1).Select
ActiveSheet.Paste
Sheets("ORIGINAL").Select
End If
Next
'Sort 'WITHOUT DUPLICATES' assets by asset ID
Sheets("WITHOUT DUPLICATES").Select
Range("A1:M10000").Select
ActiveWorkbook.Worksheets("WITHOUT DUPLICATES").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("WITHOUT DUPLICATES").Sort.SortFields.Add Key:= _
Range("D2:D10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("WITHOUT DUPLICATES").Sort
.SetRange Range("A1:M10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Correct number format for CCs for text file to put into PS
Columns("A:A").Select
Selection.NumberFormat = ""
Columns("J:J").Select
Selection.NumberFormat = ""
Range("A1").Select
Sheets("ORIGINAL").Select
Range("A1").Select
End Sub
Sub Export_xls()
'
' Export_xls Macro
'-Exports Sheets to an excel workbook (file name and location selected by user in browser
'
Dim xlsFile As String
Dim defaultFileName As String
'Get file name from user (in browser)
defaultFileName = Sheets("ORIGINAL").Range("A2").Text & " Scanned Data Reviewed-MM.dd.yyyy.xlsx"
xlsFile = Application.GetSaveAsFilename(InitialFileName:=defaultFileName, fileFilter:="Excel Workbook (*.xlsx), *.xlsx")
If xlsFile = "False" Then Exit Sub
'Create Workbook with copies of sheets and save workbook to filepath designated by user
Sheets(Array("ORIGINAL", "DUPLICATES", "WITHOUT DUPLICATES", "UNEXPECTED COST CENTERS")).Copy
ActiveWorkbook.SaveAs Filename:=xlsFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Sub Export_txt()
'
' Export_txt Macro
'-Generates txt file for inputing into PS
' Dimension all variables.
Dim txtFile As String
Dim FileNum As Integer
Dim ColumnCount As Integer
Dim RowCount As Integer
Dim defaultFileName As String
' Get destination file name.
defaultFileName = Sheets("ORIGINAL").Range("A2").Text & " Input To PS-MM.dd.txt"
txtFile = Application.GetSaveAsFilename(InitialFileName:=defaultFileName, fileFilter:="Text Files (*.txt), *.txt")
If txtFile = "False" Then Exit Sub
' Obtain next free file handle number.
FileNum = FreeFile()
' Turn error checking off.
On Error Resume Next
' Attempt to open destination file for output.
Open txtFile For Output As #FileNum
' If an error occurs report it and end.
If Err <> 0 Then
MsgBox "Cannot open filename " & xlsFile
End
End If
' Turn error checking on.
On Error GoTo 0
Sheets("WITHOUT DUPLICATES").Select
ActiveSheet.UsedRange.Select
'print 1st row without ""
RowCount = 1
For ColumnCount = 1 To Selection.Columns.Count
' Write current cell's text to file with quotation marks.
Print #FileNum, Selection.Cells(RowCount, ColumnCount).Text;
' Check if cell is in last column.
If ColumnCount = Selection.Columns.Count Then
' If so, then write a blank line.
Print #FileNum,
Else
'Otherwise, write a tab.
Print #FileNum, vbTab;
End If
' Start next iteration of ColumnCount loop.
Next ColumnCount
' Loop for each row in selection.
For RowCount = 2 To Selection.Rows.Count
' Loop for each column in selection.
For ColumnCount = 1 To Selection.Columns.Count
' Write current cell's text to file with quotation marks.
Print #FileNum, """" & Selection.Cells(RowCount, _
ColumnCount).Text & """";
' Check if cell is in last column.
If ColumnCount = Selection.Columns.Count Then
' If so, then write a blank line.
Print #FileNum,
Else
'Otherwise, write a tab.
Print #FileNum, vbTab;
End If
' Start next iteration of ColumnCount loop.
Next ColumnCount
' Start next iteration of RowCount loop.
Next RowCount
' Close destination file.
Close #FileNum
Range("A1").Select
Sheets("Instructions").Select
End Sub
Sub Run()
'
' Run Macro
'-Generates all sheets
Application.Run "'RGIS MACROS V3.xlsm'!ClearAll"
Application.ScreenUpdating = False
Application.Run "'RGIS MACROS V3.xlsm'!Import_RGIS_SCANNED"
Application.Run "'RGIS MACROS V3.xlsm'!Format"
Application.Run "'RGIS MACROS V3.xlsm'!Unexpected_Cost_Centers"
Application.Run "'RGIS MACROS V3.xlsm'!Duplicates"
Sheets("Instructions").Select
Application.ScreenUpdating = True
End Sub
Last edited:
