excel VBA 2013兼容性问题

时间:2016-04-13 10:41:45

标签: excel vba excel-vba

我刚从办公室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

0 个答案:

没有答案