| |
Option Explicit
Public フラグ
Sub パレート図作成()
Dim タイトル As String
Dim スタイル As String
Dim メッセージ As String
Dim YESNO As String
Dim Book名 As String
Dim シート名 As String
Dim SEL行 As Long
Dim SEL列 As Long
Dim 最終行 As Long
Dim 合計値 As Long
Dim 途中合計値 As Long
Dim I As Long
If ActiveSheet.ProtectContents Then
Else
メッセージ = "パレート図を作成します。" & vbLf & "" & vbLf & _
"《 ルール 》" & vbLf & _
" ・元データ左上のセルにセレクトして下さい。。" & vbLf & _
" ・範囲は、項目列・データ列の２列で構成の事とします。" & vbLf & _
" ・データ最下段下・データ列右は、空白セルである事とします。" & vbLf & "" & vbLf & _
"《 動作説明 》" & vbLf & _
" ・自動で比率を計算し、並び替えを行います。" & vbLf & _
" ・データ最下段が『その他』であれば、その部分は" & vbLf & _
" 並び替えを行いません。" & vbLf & "" & vbLf & _
"よろしいですか。"
スタイル = vbYesNo + vbQuestion + vbDefaultButton1 + vbApplicationModal
タイトル = " 【 パレート図作成 】"
YESNO = MsgBox(メッセージ, スタイル, タイトル)
If YESNO = vbYes Then
On Error GoTo エラー処理
Application.ScreenUpdating = False '画面固定
フラグ = 1
シート名 = ActiveSheet.Name
Book名 = ActiveWorkbook.Name
SEL行 = Selection.Row
SEL列 = Selection.Column
If Not IsNumeric(Cells(SEL行, SEL列 + 1)) Then '入力値が数字かどうか調べる
SEL行 = SEL行 + 1
End If
最終行 = Cells(SEL行, SEL列).End(xlDown).Row
For I = SEL行 To 最終行
Cells(I, SEL列).Select
If Cells(I, SEL列) = "" Then
Application.ScreenUpdating = True '画面固定解除
MsgBox "セレクト位置には、データがありません。", vbInformation, タイトル
Exit Sub
End If
If IsNumeric(Cells(I, SEL列)) Then
Application.ScreenUpdating = True '画面固定解除
MsgBox "項目列は、文字のみが有効です。", vbInformation, タイトル
Exit Sub
End If
Next
For I = SEL行 To 最終行
Cells(I, SEL列 + 1).Select
If Not IsNumeric(Cells(I, SEL列 + 1)) Then
Application.ScreenUpdating = True '画面固定解除
MsgBox "データ列は、数値のみが有効です。", vbInformation, タイトル
Exit Sub
End If
Next
For I = SEL行 - 1 To 最終行
Cells(I, SEL列 + 2).Select
If Cells(I, SEL列 + 2) <> "" Then
Application.ScreenUpdating = True '画面固定解除
MsgBox "データ列右横は、空白にして下さい。", vbInformation, "パレート図作成不可"
Exit Sub
End If
Next
Cells(SEL行 - 1, SEL列 + 2) = 0
If Cells(最終行, SEL列) = "その他" Then
Range(Cells(SEL行, SEL列), Cells(最終行 - 1, SEL列 + 1)).Sort Key1:=Cells(SEL行, SEL列 + 1), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Else
Range(Cells(SEL行, SEL列), Cells(最終行, SEL列 + 1)).Sort Key1:=Cells(SEL行, SEL列 + 1), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
End If
合計値 = 0
For I = SEL行 To 最終行
合計値 = 合計値 + Cells(I, SEL列 + 1)
Next
Range(Cells(SEL行 - 1, SEL列 + 2), Cells(最終行, SEL列 + 2)).NumberFormatLocal = "0%"
途中合計値 = 0
For I = SEL行 To 最終行
途中合計値 = 途中合計値 + Cells(I, SEL列 + 1)
Cells(I, SEL列 + 2) = 途中合計値 / 合計値
Next
Range(Cells(SEL行, SEL列), Cells(最終行, SEL列 + 2)).Select
Charts.Add
ActiveChart.ApplyCustomType ChartType:=xlBuiltIn, TypeName:="2 軸上の折れ線と縦棒"
ActiveChart.Location Where:=xlLocationAsObject, Name:=シート名
With ActiveChart
.Axes(xlValue, xlSecondary).MaximumScale = 1
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = 合計値
.ChartGroups(1).GapWidth = 0
.Axes(xlValue, xlSecondary).MajorUnit = 0.2
.HasLegend = False
.ChartArea.Font.Size = 9
.SeriesCollection(2).Values = "=" & シート名 & "!R" & SEL行 - 1 & "C" & SEL列 + 2 & _
":R" & 最終行 & "C" & SEL列 + 2
.SeriesCollection(2).MarkerStyle = xlCircle
.SeriesCollection(2).MarkerSize = 4
.HasAxis(xlCategory, xlSecondary) = True
.Axes(xlCategory, xlSecondary).AxisBetweenCategories = False
.Axes(xlCategory, xlSecondary).TickLabels.Font.Size = 1
.Axes(xlCategory, xlSecondary).TickLabels.Font.ColorIndex = 2
.Axes(xlCategory, xlSecondary).TickLabels.Font.Background = xlTransparent
.PlotArea.Interior.ColorIndex = 2
.SeriesCollection(1).Interior.ColorIndex = 8
End With
ActiveWindow.Visible = False
Windows(Book名).Activate
Cells(SEL行, SEL列).Select
Application.ScreenUpdating = True '画面固定解除
MsgBox "パレート図が完成しました。" & vbLf & "詳細は、各個人で設定してください。 " _
, vbInformation, タイトル
フラグ = 1
Exit Sub
エラー処理:
フラグ = 0
MsgBox "エラーが、発生しました。"
Else
MsgBox "キャンセルしました。", vbInformation, タイトル
End If
End If
End Sub
|
|
![[未読]](./data/FAQ/image/read_icon.gif){kind=icon}
