今月の 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 を使用せずに比較するだけの同様のコード ブロックが、より大きなマクロのこれらの列に対して直接正常に機能します。