我编写了一个宏,将本月的KPI数据与上个月的等效数据进行比较,然后在每个数据旁边添加一个符号,以显示效果是好是坏。如果数字接近100%,则性能会更好;如果数字越远,性能会越差。期望的结果是这样的:

[上个月的图形,本月的图形,所需符号,注释]

示例1-[98,99,↑,本月的数字接近100,因此性能得到改善]

范例2-[101,102,↓,距离100更高,因此效能较差]

示例3-[98,98,=,数字相同,因此性能没有变化]

示例4-[98,102,±,性能没有好坏,但是上个月达到了目标,如果这个数字是102,98,则本月超过了目标,反之亦然]

当下面的代码块自己运行时,它可以正常工作:

Sub Test231214()

        Range("A1").Select
        checkCell = Selection.Value
        Range("B1").Select
        newCell = Selection.Value
        'Check whether the active cell is less than, equal to or greater than the corresponding value from last month
        If newCell = checkCell Then
            'Select the cell to the right of the current selection
            Selection.Offset(0, 1).Select
            Selection.Value = "'="
        ElseIf Abs(100 - newCell) < Abs(100 - checkCell) Then
           'Select the cell to the right of the current selection
           Selection.Offset(0, 1).Select
           ActiveCell.Value = ChrW(&H2191)
        ElseIf Abs(100 - newCell) > Abs(100 - checkCell) Then
           'Select the cell to the right of the current selection
           Selection.Offset(0, 1).Select
           ActiveCell.Value = ChrW(&H2193)
        ElseIf Abs(100 - newCell) = Abs(100 - checkCell) Then
           'Select the cell to the right of the current selection
           Selection.Offset(0, 1).Select
           ActiveCell.Value = "±"
        End If

End Sub


但是当将相同的代码用作较大宏的一部分时,则不会这样:

Sub Populate_KPI_Arrows()
'
' Populate_KPI_Arrows Macro
' Opens dialogue box to select last month's KPI file, compares values and inserts arrows as appropriate.

'
'IF AN ERROR IS GENERATED AT ANY POINT DURING THE EXECUTION OF THIS MACRO THEN GO TO THE ERROR HANDLING CLAUSE
'NB: Disabled for now to make sure it is executing correctly
'On Error GoTo ErrorHandler

'SECTION 1 - CREATE NECESSARY VARIABLES AND SET VALUES

'CREATE VARIABLES FOR THE WORKBOOKS AND SHEETS TO BE COMPARED
Dim b1 As Workbook, b2 As Workbook, b3 As Workbook, w2 As Worksheet, w4 As Worksheet, w6 As Worksheet
'CREATE VARIABLE FOR THE PATH OF b1
Dim strFile As String
'CREATE VARIABLES FOR THE ARRAY OF COLUMNS TO EXAMINE AND THE INDEX OF THE CURRENT ARRAY ITEM
Dim hoursArray As Variant
Dim x As Integer

'SET ARRAYS OF COLUMNS TO EXAMINE
hoursArray = Array("B")

'TURN OFF SCREEN UPDATING TO PREVENT WORKINGS BEING DISPLAYED
Application.ScreenUpdating = False

'SET b1 AS THE WORKBOOK THIS MACRO WAS RUN FROM, strFile AS THE WORKBOOKS FILE PATH w1 AS 'Schemes KPIs' TAB & w2 AS 'Villages KPIs' TAB
Set b1 = ActiveWorkbook
strFile = ActiveWorkbook.FullName
Set w2 = ActiveWorkbook.Sheets("Villages KPIs")

'TEMPORARILY CLOSE THIS MONTHS WORKBOOK
Application.DisplayAlerts = False
b1.Close
Application.DisplayAlerts = True

'OPEN A DIALOG BOX TO SELECT LAST MONTHS FILE
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Title = "Select last month's Combined KPI's file"
    .InitialFileName = "C:\"
    'IF A FILE IS SELECTED THEN OPEN IT
    If .Show = -1 Then
        pubInputFile = .SelectedItems(1)
        txtFile = pubInputFile
        Workbooks.Open (txtFile)
        'SET b2 AS SELECTED FILE, w4 AS 'Villages KPIs' TAB
        Set b2 = ActiveWorkbook
        Set w4 = ActiveWorkbook.Sheets("Villages KPIs")
    'ELSE THE USER PRESSED CANCEL SO EXIT MACRO
    Else
        Exit Sub
    End If
End With

'UNPROTECT 'Villages KPIs' TAB OF LAST MONTHS WORKBOOK
w4.Activate
ActiveSheet.Unprotect Password:="password"

'COPY LAST MONTHS DATA TO A NEW TEMPORARY WORKBOOK, SET NEW WORKBOOK AS b3
w4.Activate
Cells.Select
Selection.Copy
Workbooks.Add
Set b3 = ActiveWorkbook
'SET w6 TO THE SHEET WITH THE DATA FROM w4
w4.Activate
Cells.Select
Selection.Copy
b3.Activate
Sheets.Add After:=Sheets(Sheets.Count)
Set w6 = ActiveSheet
ActiveSheet.Paste

'CLOSE LAST MONTHS WORKBOOK
Application.DisplayAlerts = False
b2.Close SaveChanges:=False
Application.DisplayAlerts = True

'REOPEN THIS MONTHS WORKBOOK
 If InStr(strFile, "\") = 0 Then
     Exit Sub
 End If
 Workbooks.Open Filename:=strFile

'RESET b1, w2 TO THE VALUES THAT THEY WERE BEFORE
Set b1 = ActiveWorkbook
Set w2 = ActiveWorkbook.Sheets("Villages KPIs")
'UNPROTECT 'Schemes KPIs' & 'Villages KPIs' TABS OF THIS MONTHS WORKBOOK
w2.Activate
ActiveSheet.Unprotect Password:="password"

'SECTION 2 - SELECT w2 AND THEN RUN THE FOR LOOP ON EACH COLUMN TO BE EXAMINED

'SELECT COLUMN A OF THE 'Villages KPIs' TAB IN THIS MONTHS WORKBOOK
w2.Activate
Range("A:A").Select

'COUNT THE NUMBER OF LOCATIONS ON THE CURRENT TAB
LastLocation = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 15

'LOOP THROUGH ALL ITEMS OF hoursArray
For x = LBound(hoursArray) To UBound(hoursArray)
    'LOOP THROUGH ALL ARROW CELLS FOR CURRENT COLUMN AND INSERT RELEVANT ARROW OR EQUALS SIGN
    For a_counter = 10 To LastLocation + 9
        'SELECT CELL XY WHERE X IS THE CURRENT ARRAY ITEM AND Y IS THE CURRENT VALUE OF a_counter
        w6.Activate
        w6.Range(hoursArray(x) & a_counter).Select
        checkCell = Selection.Value
        w2.Activate
        w2.Range(hoursArray(x) & a_counter).Select
        newCell = Selection.Value
        'Check whether the active cell is less than, equal to or greater than the corresponding value from last month
        If (100 - checkCell) < 0 Then
            checkCell = (checkCell * -1)
        End If
        If (100 - newCell) < 0 Then
            newCell = (newCell * -1)
        End If
        If newCell = checkCell Then
            'Select the cell to the right of the current selection
            Selection.Offset(0, 1).Select
            Selection.Value = "'="
        ElseIf (Abs(100 - newCell)) < (Abs(100 - checkCell)) Then
           'Select the cell to the right of the current selection
           Selection.Offset(0, 1).Select
           ActiveCell.Value = ChrW(&H2191)
        ElseIf (Abs(100 - newCell)) > (Abs(100 - checkCell)) Then
           'Select the cell to the right of the current selection
           Selection.Offset(0, 1).Select
           ActiveCell.Value = ChrW(&H2193)
        ElseIf (Abs(100 - newCell)) = (Abs(100 - checkCell)) Then
           'Select the cell to the right of the current selection
           Selection.Offset(0, 1).Select
           ActiveCell.Value = "±"
        End If
    Next a_counter
    'SELECT CELL XZ WHERE X IS THE CURRENT ARRAY ITEM AND Z IS THE ROW 2 BELOW THE LAST LOCATION
    w6.Activate
    w6.Range(hoursArray(x) & LastLocation + 11).Select
    checkCell = Selection.Value
    w2.Activate
    w2.Range(hoursArray(x) & LastLocation + 11).Select
    newCell = Selection.Value
    'Check whether the active cell is less than, equal to or greater than the corresponding value from last month
    If (100 - checkCell) < 0 Then
        checkCell = (checkCell * -1)
    End If
    If (100 - newCell) < 0 Then
        newCell = (newCell * -1)
    End If
    If newCell = checkCell Then
        'Select the cell to the right of the current selection
        Selection.Offset(0, 1).Select
        Selection.Value = "'="
    ElseIf (Abs(100 - newCell)) < (Abs(100 - checkCell)) Then
        'Select the cell to the right of the current selection
        Selection.Offset(0, 1).Select
        ActiveCell.Value = ChrW(&H2191)
    ElseIf (Abs(100 - newCell)) > (Abs(100 - checkCell)) Then
        'Select the cell to the right of the current selection
        Selection.Offset(0, 1).Select
        ActiveCell.Value = ChrW(&H2193)
    ElseIf (Abs(100 - newCell)) = (Abs(100 - checkCell)) Then
        'Select the cell to the right of the current selection
        Selection.Offset(0, 1).Select
        ActiveCell.Value = "±"
    End If
Next x

'PROTECT 'Villages KPIs' TAB OF THIS MONTHS WORKBOOK
w2.Activate
ActiveSheet.Protect Password:="password", DrawingObjects:=False, Contents:=True, Scenarios:= _
False

'CLOSE TEMPORARY WORKBOOK WITHOUT SAVING
Application.DisplayAlerts = False
b3.Close SaveChanges:=False
Application.DisplayAlerts = True

'TURN SCREEN UPDATING BACK ON SO ARROWS APPEAR
Application.ScreenUpdating = True

Exit Sub

'Error handler
ErrorHandler:
    Resume Next

End Sub


当作为较大宏的一部分运行时,对于超过100的数字,箭头的显示方向错误。有什么想法会发生这种情况,或者是否有更好的方法呢?一般而言,任何对整理代码的意见也将受到欢迎。

附加信息:这些工作簿中还有其他列,如果数字增加,箭头总是指向上方,并且类似的代码块不使用Abs()且仅比较newCell和checkCell对于较大的这些列都可以正常工作宏。

最佳答案

令人尴尬的问题是,“ 100-”应为“ 1-”,因为要比较的值以小数形式存储为百分比格式。感谢您的答复,我将确保观察pnuts将来共享的最佳实践文档的“最小”方面,Alex Bell提出了同样的道理。避免选择引用的指南也非常有用,因此将来也可以使用。

关于excel - MS Excel 2010-当放置在其他VBA中时,使用Abs()的计算停止工作,我们在Stack Overflow上找到一个类似的问题:https://stackoverflow.com/questions/27624284/

10-16 02:44