ここから本文です

excel2007を使ってます。 前回の質問の続きです。 横に書いてある色は文字のいろ...

rpc********さん

2018/11/520:41:14

excel2007を使ってます。
前回の質問の続きです。
横に書いてある色は文字のいろです。
何も描いていない所はセル色は白です。
B C D
125

0 赤
1220
1270
1300赤 前回青一つ前の赤
1260
1210青 前回の青
1190
1310赤 今回 A
1200青 B 1200-1310=-110
1350赤 A 1200-1350=-150
1250青
1380赤 A1380-1350=30
1200青 B 1200-1380=-180

このようにB2のセルからずっと数字が出ています。
そこに白以外の色付いている文字から+50以上で赤、-50以下で青を付けるようexcelvbaで行いました。

その隣のCセルに赤色が付いたときその前回の青色から1つ前の赤色<(より上)今回の赤色の時Aとして今回赤色の隣CセルにAと記録します。
青色が付いた時は前回の赤色から一つ前の青色>(より下)今回の青色の時Bとして今回の青色の隣CセルにBと記録します。
これに当てはまらない時は何も行いません。

セルDではAかBどちらかがセルCに記録された時記録します。
今回のセルCの隣のセルDに
前回のセルCがAだった場合
今回のセルCにAかB出た時のセルBの数字-前回セルCにAが出た時のセルBの数字
前回のセルCがBだった場合
前回セルCにBが出た時のセルBの数字-今回のセルCにAかBでた時のセルBの数字
これの計算結果を出すようにしたいです。

長く分かりにくいですが分かる方居ましたら回答よろしくお願いします。

閲覧数:
184
回答数:
2

違反報告

ベストアンサーに選ばれた回答

kky********さん

編集あり2018/11/615:26:40

30の部分がわかったので訂正します。

Sub test()
Dim i As Long, imax As Long
Dim no As Long
Dim rno As Long, bno As Long
Dim chk As String
Dim cnt As Long
imax = Cells(Rows.Count, "B").End(xlUp).Row
Range("B3:B" & imax).Interior.ColorIndex = xlNone
Range("C3:D" & imax).ClearContents
no = Range("B2").Value
rno = 0
bno = 999999999
For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
'赤色が付く
If Range("B" & i).Value >= no + 50 Then
Range("B" & i).Interior.ColorIndex = 3
'1つ前の赤色<今回の赤色の時A
If rno <> 0 And rno < Range("B" & i).Value Then
Range("C" & i).Value = "A"
cnt = cnt + 1
Else
rno = no
End If
'青色が付く
ElseIf Range("B" & i).Value <= no - 50 Then
Range("B" & i).Interior.ColorIndex = 8
'一つ前の青色>今回の青色の時B
If bno <> 999999999 And bno > Range("B" & i).Value Then
Range("C" & i).Value = "B"
cnt = cnt + 1
Else
bno = no
End If
End If
'CがAかBで、前回がAだった時
If Range("C" & i) <> "" And chk = "A" And cnt > 1 Then
Range("D" & i).Value = Range("B" & i).Value - rno
rno = no
'CがAかBで、前回がBだった時
ElseIf Range("C" & i) <> "" And chk = "B" And cnt > 1 Then
Range("D" & i).Value = bno - Range("B" & i).Value
bno = no
End If
If Range("C" & i).Value = "A" Then
chk = "A"
rno = Range("B" & i).Value
ElseIf Range("C" & i).Value = "B" Then
chk = "B"
bno = Range("B" & i).Value
End If
If Range("B" & i).Interior.ColorIndex <> xlNone Then
no = Range("B" & i).Value
End If
Next i
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

ベストアンサー以外の回答

1〜1件/1件中

jiy********さん

編集あり2018/11/614:04:45

初回回答が間違えていましたので、再回答です。

D13セルについては私の勘違いでした。(前回Cセルは11行目の"A"なので、D13セルの値は、「今回のBセル - 前回"A"のBセル」で「30」が正しいということですね。)

初回回答と同様に、D列に数式を入れたい場合は

Range("D" & irow).Value = .Value - wk_BZenA '☆1

Range("D" & irow).Value = Replace("=" & .Address & "-" & wk_BZenA.Address, "$", "")

Range("D" & irow).Value = wk_BZenB - .Value '☆2

Range("D" & irow).Value = Replace("=" & wk_BZenB.Address & "-" & .Address, "$", "")

としてください。

Sub sample()
    Dim irow As Long, lrow As Long
    Dim wkB As Long
    Dim wkZenC_AorB As String, wk_BZenA As Range, wk_BZenB As Range
    Dim wk_CRed(1) As Range '(0)仮、(1)確定
    Dim wk_CBlu(1) As Range '(0)仮、(1)確定
    
    lrow = Cells(Rows.Count, "B").End(xlUp).Row
    Columns("B").Interior.Color = xlNone
    Range("B2").Interior.Color = vbRed
    Range("C2:D" & lrow).ClearContents
    wkB = Range("B2").Value
    For irow = 3 To lrow
        With Range("B" & irow)
            'B列を赤
            If .Value >= wkB + 50 Then
                .Interior.Color = vbRed
                wkB = .Value
                'C列AorB記載判定
                If Not wk_CRed(1) Is Nothing Then
                    If wk_CRed(1) < .Value Then
                        Range("C" & irow) = "A"
                    End If
                End If
                Set wk_CRed(0) = Range(.Address) '赤値(仮)
                
                'C列判定のための青確定値
                If Not wk_CBlu(0) Is Nothing Then
                    Set wk_CBlu(1) = wk_CBlu(0) '青値(確定)
                    Set wk_CBlu(0) = Nothing
                End If
                
            'B列を青
            ElseIf .Value <= wkB - 50 Then
                .Interior.Color = vbBlue
                wkB = .Value
                
                'C列AorB記載判定
                If Not wk_CBlu(1) Is Nothing Then
                    If wk_CBlu(1) > .Value Then
                        Range("C" & irow) = "B"
                    End If
                End If
                Set wk_CBlu(0) = Range(.Address) '青値(仮)
                
                'C列判定のための赤確定値
                If Not wk_CRed(0) Is Nothing Then
                    Set wk_CRed(1) = wk_CRed(0) '赤値(確定)
                    Set wk_CRed(0) = Nothing
                End If
            End If
            If Range("C" & irow) <> "" Then
                Select Case wkZenC_AorB
                    Case "A"
                        If Not wk_BZenA Is Nothing Then
                            Range("D" & irow).Value = .Value - wk_BZenA '☆1
                        End If
                        Set wk_BZenA = Range(.Address)
                    Case "B"
                        If Not wk_BZenB Is Nothing Then
                            Range("D" & irow).Value = wk_BZenB - .Value '☆2
                        End If
                        Set wk_BZenB = Range(.Address)
                End Select
                Select Case Range("C" & irow)
                    Case "A"
                        Set wk_BZenA = Range(.Address)
                    Case "B"
                        Set wk_BZenB = Range(.Address)
                End Select
                wkZenC_AorB = Range("C" & irow)
            End If
        End With
    Next irow
End Sub

以下、初回回答(間違えています。)
==========================

>1380赤 A1380-1350=30
の行ですが、D13セルは「30」ではなく「-30」ではないでしょうか?(1350-1380ではないかと思います。私の勘違いでしょうか。)

D列には計算結果を表示するようにしていますが、これをもし数式で入れたい場合には

Range("D" & irow).Value = wkD - .Value '☆1

Range("D" & irow).FormulaLocal = Replace("=" & wkC.Address & "-" & .Address, "$", "")

Range("D" & irow).Value = .Value - wkD '☆2

Range("D" & irow).FormulaLocal = Replace("=" & .Address & "-" & wkC.Address, "$", "")

のように2箇所変更してください。

特に工夫もなくそのまま書いています。分かる方でしたらもっと簡潔に書けるのかも知れません。

シートモジュールに記載してください。

Sub sample()
    Dim irow As Long, lrow As Long
    Dim wkB As Long
    Dim wkD As Range
    Dim wkCRed(1) As Range '(0)仮、(1)確定
    Dim wkCBlu(1) As Range '(0)仮、(1)確定
    
    lrow = Cells(Rows.Count, "B").End(xlUp).Row
    Columns("B").Interior.Color = xlNone
    Range("B2").Interior.Color = vbRed
    Range("C2:D" & lrow).ClearContents
    wkB = Range("B2").Value
    For irow = 3 To lrow
        With Range("B" & irow)
            'B列を赤
            If .Value >= wkB + 50 Then
                .Interior.Color = vbRed
                wkB = .Value
                'C列AorB記載判定
                If Not wkCRed(1) Is Nothing Then
                    If wkCRed(1) < .Value Then
                        Range("C" & irow) = "A"
                        If Not wkD Is Nothing Then
                            Range("D" & irow).Value = wkD - .Value '☆1
                        End If
                        Set wkD = Range(.Address)
                    End If
                End If
                Set wkCRed(0) = Range(.Address) '赤値(仮)
                
                'C列判定のための青確定値
                If Not wkCBlu(0) Is Nothing Then
                    Set wkCBlu(1) = wkCBlu(0) '青値(確定)
                    Set wkCBlu(0) = Nothing
                End If
                
            'B列を青
            ElseIf .Value <= wkB - 50 Then
                .Interior.Color = vbBlue
                wkB = .Value
                
                'C列AorB記載判定
                If Not wkCBlu(1) Is Nothing Then
                    If wkCBlu(1) > .Value Then
                        Range("C" & irow) = "B"
                        If Not wkD Is Nothing Then
                            Range("D" & irow).Value = .Value - wkD '☆2
                        End If
                        Set wkD = Range(.Address)
                    End If
                End If
                Set wkCBlu(0) = Range(.Address) '青値(仮)
                
                'C列判定のための赤確定値
                If Not wkCRed(0) Is Nothing Then
                    Set wkCRed(1) = wkCRed(0) '赤値(確定)
                    Set wkCRed(0) = Nothing
                End If
            End If
        End With
    Next irow
End Sub

初回回答が間違えていましたので、再回答です。...

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる