我刚从办公室2010升级到办公室2013.我在办公室2010运行的VBA脚本完全正常,没有任何问题,因为当点击按钮运行代码时,它现在崩溃了。我逐行遍历代码,看看问题是什么,但它工作正常,没有崩溃,它完成了它想做的一切。
这是兼容性问题吗?我知道脚本是正确的,但它知道导致excel没有响应并在单击按钮时关闭,并且脚本现在运行速度非常慢,而且速度很快。
以下是我正在运行的代码:
Dim x As Workbook 'Saved workbook from email (MEP)
Dim y As Workbook 'Saved workbook from email (PS)
Dim sht1 As Worksheet 'Current active worksheet (Formatted)
Dim LResult As String
Dim RangeSort As Range
Dim RangeKey As Range
Dim majVarCount As Integer
Dim minVarCount As Integer
Dim onTrackCount As Integer
Dim rng As Range
Dim iVal As Integer
Dim compStartRow As Integer
Dim compEndRow As Integer
'Open Closed Project PS report
Set y = Workbooks.Open("C:\documents\Closed.xlsx") 'Path for workbook to copy from
lastRow = Cells(Rows.Count, 2).End(xlUp).Row 'Find the last row
Rows(lastRow).Delete 'Deletes un-necessary row
'Find last row again after deleting un-necessary row
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'Copy over required data
Range("B6:E" & lastRow).Select
Selection.Hyperlinks.Delete
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("E22").Insert Shift:=xlDown
Range("F6:F" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("K22").Insert Shift:=xlDown '(Global/Regional)
Range("G6:G" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("M22").Insert Shift:=xlDown
Range("H6:H" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("X22").Insert Shift:=xlDown
Range("I6:K" & lastRow).Select
Selection.Copy
Workbooks("Formatted").Worksheets("Formatted").Range("AS22").Insert Shift:=xlDown
Application.DisplayAlerts = False
y.Close
'To remove characters after the first blank space in column M
lastRow = Cells(Rows.Count, "M").End(xlUp).Row
Range("M22:M" & lastRow).Replace What:=" *", Replacement:="", LookAt:=xlPart
'Change strings from "Green = OnTrack, Amber = Minor Variance, Red = Significant Variance"
With Range("AS:AU")
.Replace What:="Green", Replacement:="On Track"
.Replace What:="Amber", Replacement:="Minor Variance"
.Replace What:="Red", Replacement:="Significant Variance"
End With
'Checking the last row
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
'Used to confirm that LastRow worked displays as message
'MsgBox "Last Row: " & lastRow
'Searching for blank cells and populating with'On track'
With Range("AS22:AU" & lastRow)
.Replace What:="", Replacement:="On Track"
End With
With Range("X22:X" & lastRow)
.Replace What:="", Replacement:="Complete"
End With
'Clear contents in column DP no not needed
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
Range("DP22:DP" & lastRow).ClearContents
With Worksheets("Formatted")
lastRow = .Cells(Rows.Count, 5).End(xlUp).Row
For Each rng In .Range("DP22:DP" & lastRow)
rng.Formula = "=IF(COUNTIF(AS" & rng.Row & ":AU" & rng.Row & ", ""Significant Variance""), ""Significant Variance"", " & _
"IF(COUNTIF(AS" & rng.Row & ":AU" & rng.Row & ", ""Minor Variance""), ""Minor Variance"", " & _
"""On Track""))"
rng.Value = rng.Value
Next rng
End With
'Find the range of cells for Complete Project
compStartRow = Range("X:X").Find(What:="Complete", after:=Range("X21")).Row
compEndRow = Range("X:X").Find(What:="Complete", after:=Range("X21"), SearchDirection:=xlPrevious).Row
'MsgBox "First and Last Row for Complete Projects: " & compStartRow & compEndRow 'Used for checking first and last row values are correct
'Counts the values and paste in to Count Table sheet
iVal = Application.WorksheetFunction.CountIf(Range("DP" & compStartRow & ":DP" & compEndRow), "On Track")
Worksheets("Count Table").Range("E8").Value = iVal
iVal = Application.WorksheetFunction.CountIf(Range("DP" & compStartRow & ":DP" & compEndRow), "Minor Variance")
Worksheets("Count Table").Range("D8").Value = iVal
iVal = Application.WorksheetFunction.CountIf(Range("DP" & compStartRow & ":DP" & compEndRow), "Significant Variance")
Worksheets("Count Table").Range("C8").Value = iVal
'Clear contents in column DP not needed
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
Range("DP22:DP" & lastRow).ClearContents
'Copy information from the Lookup table sheet into the Formatted sheet and clears the clipboard
Sheets("Lookup Table").Range("C5").Copy Sheets("Formatted").Range("L22:L" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C4").Copy Sheets("Formatted").Range("J22:J" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C6").Copy Sheets("Formatted").Range("K22:K" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C8").Copy Sheets("Formatted").Range("Q22:Q" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C10").Copy Sheets("Formatted").Range("AQ22:AQ" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C11").Copy Sheets("Formatted").Range("AR22:AR" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C13").Copy Sheets("Formatted").Range("BD22:BD" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C15").Copy Sheets("Formatted").Range("BF22:BF" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C17").Copy Sheets("Formatted").Range("BH22:BH" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C19").Copy Sheets("Formatted").Range("BJ22:BJ" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C21").Copy Sheets("Formatted").Range("BL22:BL" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C23").Copy Sheets("Formatted").Range("BN22:BN" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C24").Copy Sheets("Formatted").Range("BO22:BO" & lastRow)
Application.CutCopyMode = False
Sheets("Lookup Table").Range("C25").Copy Sheets("Formatted").Range("BP22:BP" & lastRow)
Application.CutCopyMode = False
'Remove cell borders
Set rng = ActiveSheet.Range("E22:BP" & lastRow)
rng.Borders.LineStyle = xlNone
'Save formatted sheet as new workbook before overlay has been applied
FPath = "C:\documents\Reports\formatted\"
FName = "Formatted with Closed" & Format(Now, "ddmmmyyyy_hhmm") & ".xls"
Set NewBook = Workbooks.add
ThisWorkbook.Sheets("Formatted").Copy Before:=NewBook.Sheets(1)
NewBook.SaveAs Filename:=FPath & "\" & FName
Application.DisplayAlerts = False
NewBook.Close