[[20211116213121]]　『複数列の最大値を求めるVBA』（SIKOUTYUU）　ページの最後に飛ぶ

『複数列の最大値を求めるVBA』（SIKOUTYUU）

はじめまして。

複数列に格納されていく数値の最大値のセルに色付けするVBAをご教授ください。
A2セルには
リストボックス形式で各項目名が入っています
A13セルには
項目Aが入ります。
このこうもくAは3行のセルが結合されています。
B13セルにはオーダーという文字が入ります
B14セルには生産性という文字が入ります
B15セルには台数という文字が入ります

A16セルには
項目Bが入ります。
このこうもくAは3行のセルが結合されています。
B17セルにはオーダーという文字が入ります
B18セルには生産性という文字が入ります
B19セルには台数という文字が入ります
という感じで
全部で項目が50項目ぐらいあります。

流れとしましては
A.項目を選ぶ
B.ボタンを押す
C.ユーザーフォームの各項目を入力していく
D.選んだ項目と同じ項をA列から探し、オーダー、生産性、台数の右隣の
最後に入力されている列の右隣の入力した数値が入る
という感じです。

ここで、生産性の列に入力されている数値の最大値を求めそのセルを水色に色付けしたいです。
列はどんどん増えていきます。
よって最大値も変わっていきます。
最大値が変わったときは前の最大値を水色から白に色付けして、新しい最大値に水色に色付けしたいです。

このようなVBAを作成するのはどうしたらよいでしょうか？
どうかご教授ください。

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

コード作成について、ご自身でどの程度取り組まれているか教えてください。
ユーザーフォームも採用するとのことなので、そのおおよそのレイアウトについても教えてください。
（めざめるパワー） 2021/11/16(火) 22:34

＞右隣の
＞最後に入力されている列の右隣の入力した数値が入る

図で右隣が C列でさらに右ということは D列にも値が入力される？

図　

     |[A]  |[B]     |[C]|[D]
 [13]|項目A|オーダー| 43|
 [14]|     |生産性  | 44|？
 [15]|     |台数    | 21|
 [16]|項目B|オーダー|  8|
 [17]|     |生産性  | 20|
 [18]|     |台数    | 37|

＞列はどんどん増えていきます。
列ではなく行ですよね。文中に出てくる列とは行だと思うけど。

案です。

    |[A]  |[B]     |[C]   |[D] 
 [1]|     |オーダー|生産性|台数
 [2]|項目A|      43|    44|  21
 [3]|項目B|       8|    20|  37

これだと関数、条件書式で出来ますよね。
（PP） 2021/11/16(火) 23:47

縦方向では項目選択し、
データそのものは、横に増えていくのでしょうね、きっと。
言葉に加えて、簡単な実例によるレイアウトを質問者さんが示せば、
もっと早く回答が得られたのではないかなと思います。

（γ） 2021/11/17(水) 01:02

みなさん。
おはようございます。
説明不足で申し訳ございません。

簡単なレイアウトを示します

     |[A]      |[B]     |[C]    |[D]    |[E]     |[F]    |[G]      |[H]      |[I]            |[J]      |[K]      
 [1] |項目名   |        |       |       |        |       |         |         |               |         |         
 [2] |         |        |       |       |        |       |         |         |               |         |         
 [3] |         |        |       |       |        |       |         |         |               |         |         
 [4] |         |        |       |       |        |       |         |         |               |         |         
 [5] |         |        |       |       |        |       |         |         |               |         |         
 [6] |         |        |       |       |        |       |         |         |               |         |         
 [7] |         |        |       |       |        |       |         |         |               |         |         
 [8] |         |        |       |       |        |       |         |         |               |         |         
 [9] |         |        |       |       |        |       |         |         |               |         |         
 [10]|         |        |       |       |        |       |         |         |               |         |         
 [11]|         |        |       |       |        |       |         |         |               |         |         
 [12]|項目名   |        |       |       |        |       |         |         |               |         |         
 [13]|CBD-1661A|オーダー|A011   |       |        |       |         |         |               |         |         
 [14]|         |正味    |       |       |        |       |         |         |               |         |         
 [15]|         |台数    |    200|       |        |       |         |         |               |         |         
 [16]|CBM-221  |オーダー|A092   |A121   |A130    |A167   |A175     |A184     |A219           |A231     |A246     
 [17]|         |正味    |79.33% |90.54% |146.83% |131.88%|92.30%   |124.48%  |144.89%        |154.49%  |101.19%  
 [18]|         |台数    |7/100  |     50|      50|     70|       50|       55|             50|28+10/50 |       30
 [19]|HK-Y04   |オーダー|A194   |       |        |       |         |         |               |         |         
 [20]|         |正味    |34.19% |       |        |       |         |         |               |         |         
 [21]|         |台数    |46/50  |       |        |       |         |         |               |         |         
 [22]|NBB-724  |オーダー|       |A143   |A158    |A178   |A178/A217|A217/A237|A237/A258      |A281/258 |A281     
 [23]|         |正味    |       |132.76%|139.14% |119.73%|153.49%  |177.91%  |130.71%        |142.20%  |108.58%  
 [24]|         |台数    |       |    100|     100|     86|2+94     |6+93     |5+26           |45+5     |       38
 [25]|NBD-577C |オーダー|A077   |A188   |A118+196|A215   |A241     |A244     |A256/A275A/A284|A293/A298|A298/A321
 [26]|         |正味    |93.75% |76.42% |113.26% |98.17% |153.11%  |104.33%  |150.91%        |137.61%  |181.05%  
 [27]|         |台数    |    128|     45|31+72   |     68|       52|       52|            125|      120|      106
 [28]|NBD-865  |オーダー|A172   |A180   |A205    |A216   |A229     |A242/257 |A257/271       |A271     |A276     
 [29]|         |正味    |176.32%|259.81%|203.84% |349.94%|449.53%  |382.82%  |281.34%        |363.86%  |186.28%  
 [30]|         |台数    |    112|     64|     100|    100|      100|100+14   |86+14          |       96|       95
 [31]|NBG-320  |オーダー|       |A163   |A173    |A179   |A190     |A190     |A218           |A230     |A230/245 
 [32]|         |正味    |       |408.16%|253.64% |141.69%|198.02%  |198.02%  |116.74%        |231.63%  |176.54%  
 [33]|         |台数    |       |     96|      80|    108|      100|      100|             88|       69|3+46     
 [34]|NBG-720  |オーダー|B288   |B289   |B299    |B305   |B319     |B325     |B325           |B328     |B334     
 [35]|         |正味    |142.93%|252.69%|79.76%  |79.86% |67.64%   |93.52%   |120.33%        |91.95%   |122.19%  
 [36]|         |台数    |      5|      5|       5|      5|        5|       10|              5|        5|        5
レイアウトに示すように
データーは横に増えていきます。

VBAですが、
最後のユーザーフォームに記載されているコードを示します
Worksheets("一時保管").Range("H3").Value = Worksheets("総合一覧表").Range("A5")

 Worksheets("総合一覧表").Range("A5").MergeArea.ClearContents
    Dim wsTemp As Worksheet
Set wsTemp = ThisWorkbook.Worksheets("一時保管")
 Dim ws As Worksheet
 Dim rng1 As Range
       Set ws = Worksheets(CStr(wsTemp.Range("H3").Value))
          Set rng1 = ws.Cells.Find("オーダー", LookAt:=xlWhole)
          If Not rng1 Is Nothing Then
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 0).ClearContents

            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(1, 1).ClearContents
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(2, 1).ClearContents

            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(4, 1).ClearContents
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(6, 1).ClearContents
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(7, 1).ClearContents
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(8, 1).ClearContents
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Interior.ColorIndex = 0
        End If
 Worksheets("総合一覧表").Range("A5").MergeArea.ClearContents
Dim rng3 As Range
    Set rng3 = Worksheets("総合一覧表").Cells.Find(Sheets("一時保管").Range("H3").Value, LookAt:=xlWhole)
    If Not rng3 Is Nothing Then
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).ClearContents

rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(1, 0).ClearContents
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(2, 0).ClearContents
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 0).Interior.ColorIndex = 0
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 0).ClearContents
End If
End Sub
多々違和感があるかと思いますがご容赦ください。
どうかよろしくお願いします。

（SIKOUTYUU） 2021/11/17(水) 07:14

 Sub Sample1(order, Productivity, Volume)
    Dim ws As Worksheet
    Dim SearchKey As String
    Dim i As Long
    Set ws = ActiveSheet
    With ws
        SearchKey = .Range("A2").Value
        For i = 13 To .Cells(Rows.Count, "A").Row Step 3
            With .Cells(i, "A")
                If .Value = SearchKey Then
                    With .End(xlToRight).Offset(, 1)
                        .Value = order
                        .Offset(1).Value = Productivity
                        .Offset(2).Value = Volume
                        Call Sample2(.Offset(1))
                    End With
                    'Exit For   'お好みで
                End If
            End With
        Next
    End With
 End Sub

 Sub Sample2(rng As Range)
    Dim fmcRange As Range
    With rng.Worksheet
        Set fmcRange = .Range(rng, .Cells(rng.Row, "C"))
    End With
    With fmcRange.FormatConditions
        .Delete
        With .AddTop10
            .SetFirstPriority
            .Rank = 1
            .Interior.Color = 15773696
        End With
    End With
 End Sub

試作してみました。
ある程度マクロの知識がありそうなのであまりくどくどと解説はしません。
（めざめるパワー） 2021/11/17(水) 08:56

 こういうことですか？
 すでに回答いただいていますが、せっかく書いたので、枯れ木として提示しておきます。

 Sub test()
     Dim rng As Range
     Dim target As Range
     Dim v As Variant
     Dim vv As Variant
     Dim e As Variant
     Dim maxvalue As Double
     Dim k As Long

     With Worksheets("総合一覧表")
         Set rng = .Columns("A").Find(Sheets("一時保管").Range("H3").Value, LookAt:=xlWhole)
         Set target = .Range(rng.Offset(2, 2), Cells(rng.Row + 2, Columns.Count).End(xlToLeft))

         '最大値の取得
         v = target.Value
         ReDim w(1 To UBound(v, 2)) As Double
         For k = 1 To UBound(v, 2)
             vv = Trim(v(1, k))
             If vv <> "" Then
                 w(k) = Application.Evaluate(vv)
             End If
         Next
         maxvalue = Application.Max(w)

         '最大値のセル（複数あり）に着色
         target.Interior.ColorIndex = 0
         k = 0
         For Each e In v
             k = k + 1
             If maxvalue = w(k) Then
                 target(k).Interior.Color = vbRed
             End If
         Next
     End With
 End Sub

（γ） 2021/11/17(水) 09:15

（γ）さん
返信遅くなりすみません。
VBA試した所
台数の項目の最大値が赤くなりました。
さらに
If maxvalue = w(k) Then
のw(k)でインデックス範囲がありませんとでました。

（SIKOUTYUU） 2021/11/17(水) 16:49

こちらの手違いで
項目の列はA列ではなくB列でした。
大変失礼しました。
（sikouthut） 2021/11/17(水) 17:00

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Then
If TextBox1 <> "" Then
Worksheets("一時保管").Range("B13").Value = TextBox1

If StrPtr(TextBox1) = 0 Then Exit Sub

   Dim wsTemp As Worksheet
Set wsTemp = ThisWorkbook.Worksheets("一時保管")
 Dim ws As Worksheet
 Dim rng1 As Range
       Set ws = Worksheets(CStr(wsTemp.Range("F3").Value))
          Set rng1 = ws.Cells.Find("オーダー", LookAt:=xlWhole)
          If Not rng1 Is Nothing Then
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = wsTemp.Range("B3")
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(1, 0).Value = wsTemp.Range("B6")
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(4, 0).Value = wsTemp.Range("B10")
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(6, 0).Value = wsTemp.Range("D9")
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(7, 0).Value = wsTemp.Range("B14")
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(8, 0).Value = wsTemp.Range("F9")
            rng1.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 0).Interior.ColorIndex = 6
        End If

 Worksheets("総合一覧表").Range("A5").MergeArea.ClearContents
Dim rng3 As Range
    Set rng3 = Worksheets("総合一覧表").Cells.Find(Sheets("一時保管").Range("F3").Value, LookAt:=xlWhole)
    If Not rng3 Is Nothing Then
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = wsTemp.Range("B3")

rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(1, 0).Value = wsTemp.Range("B5")
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(2, 0).Value = wsTemp.Range("B10")
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 0).Interior.ColorIndex = 6
rng3.EntireRow.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 0).Select
End If

     Dim rng As Range
     Dim target As Range
     Dim v As Variant
     Dim vv As Variant
     Dim e As Variant
     Dim maxvalue As Double
     Dim k As Long
     With Worksheets("総合一覧表")
         Set rng = .Columns("B").Find(Sheets("一時保管").Range("F3").Value, LookAt:=xlWhole)
         Set target = .Range(rng.Offset(2, 2), Cells(rng.Row + 2, Columns.Count).End(xlToLeft))
         '最大値の取得
         v = target.Value
         ReDim w(1 To UBound(v, 2)) As Double
         For k = 1 To UBound(v, 2)
             vv = Trim(v(1, k))
             If vv <> "" Then
                 w(k) = Application.Evaluate(vv)
             End If
         Next
         maxvalue = Application.Max(w)
         '最大値のセル（複数あり）に着色
         target.Interior.ColorIndex = 0
         k = 0
         For Each e In v
             k = k + 1
             If maxvalue = w(k) Then
                 target(k).Interior.Color = vbRed
             End If
         Next
     End With

wsTemp.Range("B3").ClearContents
wsTemp.Range("B13").ClearContents
wsTemp.Range("B8").ClearContents
wsTemp.Range("D8").ClearContents
wsTemp.Range("F3").ClearContents
ThisWorkbook.Save
Unload Me

End If
End If

End Sub
現在のコードです。
実行していくと、
If maxvalue = w(k) Thenで
インデックスが有効範囲にありませんとでます。
どこを修正すればよいでしょうか？

 ReDim w(1 To UBound(v, 2)) As Double
         For k = 1 To UBound(v, 2)
             vv = Trim(v(1, k))
のコードの意味を教えていただかると助かります。
申し訳ありませんがよろしくお願いいたします。

（SIKOUTYUU） 2021/11/17(水) 20:41

Set target = .Range(rng.Offset(2, 2), Cells(rng.Row + 2, Columns.Count).End(xlToLeft))
の Cellsの頭にドットが抜けていました。失礼しました。

データのなかに、数値でない、計算式のごときものがありますね。
それを計算して数値にしないといけなかったわけです。
数値化した結果の一次元配列が w のつもりです。
　
式のなかに無用なスペースがあると計算ができないので、
不要なスペースをTrimで除いたつもりです。
文字列の間に不要なスペースが残っているのかもしれません。
　
いずれにしても、そちらでデバッグしてください。
ローカルウインドウでそのときの配列 w がどうなっているかを
実際のデータに即して観察してください。
こちらでは出来かねます。
　
# こちらの手元のデータでは（上記のミスはありましたが）結果はでていました。

（γ） 2021/11/17(水) 21:59

なんか見覚えがあるな～(-_-メ)
（チンチクリン） 2021/11/17(水) 22:38

ご迷惑をお掛けすみませんでした。

赤くなるのは台数の部分でした。
どうしても、インデックスが有効範囲のエラー原因がわかりませんでした。
基本的にデーターの中には数式は入っていません。

いろいろ思考錯誤しましが、ダメでしたので今回はこれで撤退させていただきます。

いろいろとお付き合いいただきありがとうございました。

（SIKOUTYUU） 2021/11/18(木) 01:31

 それは残念ですが、そちらのご判断ですから致し方ないですね。

 (1)エラーになったときの、kの値、wの配列の大きさや内容の確認などはされたのですか？
 ＞ローカルウインドウでそのときの 配列 w がどうなっているかを
 ＞実際のデータに即して観察してください。
 私の手元では正常動作しているので、動かないといわれても完全にお手上げです。

 (2)
 ＞基本的にデーターの中には数式は入っていません。
 とのこと。

 7/100
 28+10/50
 46/50
 2+94
 6+93
 などのことを申し上げたわけですが、これは数値ではなく文字列ですよね。

 そういうデータは一切なく、例示は単なる架空のもので、すべて数値なら、
 PPさん、めざめるパワーさんの提示された条件付き書式で対応可能でしょう。
（γ） 2021/11/18(木) 07:32

おはよう御座います。
ローカルウィンドウで確認はしました。
kの大きさは正味から右に入っている数分だけのセルブレス表示されていました。
wの大きさは正味を除いたみぎに入っている数値すべて表示されていました。
確かに指摘された数式の件はおっしゃる通り数式でした。
失礼しました。

（sikouthut） 2021/11/18(木) 07:44

エラーになったとき、
整数kの値はいくつで、LBOUND(w),UBOUND(w)の値はそれぞれいくつですか？

（γ） 2021/11/18(木) 07:49

返信遅くなりすみません
整数Kの値は正味を含めて10でした。
LBOUND(w),UBOUND(w)ですが、
VBA上のどの場所を見ればよいでしょうか？
現在は
ReDim w(1 To UBound(v, 2)) As Double

         For k = 1 To UBound(v, 2)
の中にUBound(v, 2)がありますが
その場所にカーソルを充てると
UBound(v, 2）=9とでます。

（SIKOUTYUU） 2021/11/18(木) 12:28

 Set target = .Range(rng.Offset(2, 2), Cells(rng.Row + 2, Columns.Count).End(xlToLeft))
 これを
 Set target = .Range(.Cells(rng.Row + 2, "D"), .Cells(rng.Row + 2, Columns.Count).End(xlToLeft))
 に変更してください。
 vのもとになっているtargetについて、イミディエイトウインドウで、
 ?target.Address 
 と確認してもらえば、台数のセル範囲をきちんと指しているか確認できたはずです。

 B列は結合されているのですね。作成・検証でまったく念頭に置いていませんでした。
 #  セル結合は使わないようにしたほうがいいです。
（γ） 2021/11/18(木) 13:35

（γ）さん
無事に希望するものが出来ました。
セルに結合の件説明したつもりでしたが、申し訳ありませんでした。

長々ちお付き合いいただきありがとうございました。

では失礼します。
（SIKOUTYUU） 2021/11/18(木) 21:25

コメント返信：

[ 一覧(最新更新順) ]

[[20211116213121]] 『複数列の最大値を求めるVBA』（SIKOUTYUU） ページの最後に飛ぶ

[[20211116213121]]　『複数列の最大値を求めるVBA』（SIKOUTYUU）　ページの最後に飛ぶ