目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
252 / 262 ←次へ | 前へ→

【11】パレート図
Excel  ぴかる  - 02/9/2(月) 21:08 -

引用なし
パスワード
   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 & _
        " ・範囲は、項目列・データ列の2列で構成の事とします。" & 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

5,489 hits

【4】アドインファイルにてツールバーを表示するには、[ソフト紹介] ぴかる 02/9/2(月) 20:42 Excel[未読]
【5】マクロ構成とセット方法 ぴかる 02/9/2(月) 20:54 Excel[未読]
【6】ThisWorkbook ぴかる 02/9/2(月) 20:56 Excel[未読]
【7】標準モジュール ぴかる 02/9/2(月) 21:02 Excel[未読]
【8】セッティング ぴかる 02/9/2(月) 21:03 Excel[未読]
【9】ツールバー ぴかる 02/9/2(月) 21:06 Excel[未読]
【10】つづき ぴかる 02/9/2(月) 21:07 Excel[未読]
【11】パレート図 ぴかる 02/9/2(月) 21:08 Excel[未読]
【12】メイン ぴかる 02/9/2(月) 21:15 Excel[未読]
【13】メニューバー ぴかる 02/9/2(月) 21:19 Excel[未読]
【14】つづき ぴかる 02/9/2(月) 21:20 Excel[未読]
【15】各種マクロ ぴかる 02/9/2(月) 21:21 Excel[未読]
【16】小ワザ集 ぴかる 02/9/2(月) 21:23 Excel[未読]
【17】つづき ぴかる 02/9/2(月) 21:25 Excel[未読]
【18】つづきのつづき ぴかる 02/9/2(月) 21:25 Excel[未読]
【19】小ワザ集97 ぴかる 02/9/2(月) 21:27 Excel[未読]
【20】つづき ぴかる 02/9/2(月) 21:27 Excel[未読]
【21】つづきのつづき ぴかる 02/9/2(月) 21:28 Excel[未読]
【22】入力設定 ぴかる 02/9/2(月) 21:29 Excel[未読]
【25】文字変換 ぴかる 02/9/2(月) 21:32 Excel[未読]
【26】Class1 ぴかる 02/9/3(火) 7:57 Excel[未読]
【27】最後に ぴかる 02/9/3(火) 12:52 Excel[未読]

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
252 / 262 ←次へ | 前へ→
ページ:  ┃  記事番号:   
0
(SS)C-BOARD v3.8 is Free