[[20230901145126]]　『マクロでセルの値変換』（メガネ）　ページの最後に飛ぶ

『マクロでセルの値変換』（メガネ）

下記のような表で同一列にAが3個ある場合、上から2番目のAをCに変換したい
できればマクロでの方法を教えてください。

	A_	B_	C_
1_	あ	い	う
2_	C	C	C
3_	C	A	C
4_	A	A	C
5_	C	C	C
6_	A	A	C
7_	C	C	C
8_	A	C	C
9_	C	C	A
10_	C	C	C
11_	C	C	A
12_	C	C	A

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

同一シートに上記以外の表がないことが前提で
Sub Sample()

    '
    Dim rng As Range
    Dim r   As Long
    Dim er  As Long
    Dim c   As Long
    Dim ec  As Long
    Dim v   As Variant
    Dim f   As Boolean

    '
    Set rng = Worksheets(該当シート名かインデックス).UsedRange
    v = rng.Value

    '
    er = rng.Rows.Count
    ec = rng.Columns.Count

    For c = 1 To ec
        f = False
        For r = 1 To er
            If v(r, c) = "A" Then
                Select Case f
                    Case True:  v(r, c) = "C": Exit For
                    Case False: f = True
                End Select
            End If
        Next r
    Next c

    rng.Value = v

End Sub

シート名はダブルコーテーションで括ってくださいな
（ 'ふ'） 2023/09/01(金) 16:13:57

'ふ'さん　ありがとうございます。上から2番目のAがCに変更できました。
このコードに「列にAが3個の場合実行する」を追加したいのですがどのように記述したらよいか教えてください。
（メガネ） 2023/09/02(土) 12:56:43

 ざっくり↓こんな風に考えれば宜しいかと。
 (やってる事は結局'ふ'さんの例と同じ事です)

    Dim c As Range, r As Range, a As Range, i As Long
    For Each c In [A2:C12].Columns
        For Each r In c.Rows
            If r.Value = "A" Then i = i + 1
            If i = 3 Then Exit For
            If a Is Nothing Then If i = 2 Then Set a = r
        Next
        If i = 3 Then a.Value = "[C]"
        Set a = Nothing
        i = 0
    Next

（白茶） 2023/09/02(土) 13:34:35

 こんな感じにも書けますね。

 Sub test()
     Dim rng   As Range
     Dim r     As Range
     Dim cnt   As Long

     For Each rng In Range("A1").CurrentRegion.Columns
         If Application.CountIf(rng, "A") = 3 Then
             cnt = 0
             For Each r In rng.Cells
                 If r = "A" Then
                     cnt = cnt + 1
                     If cnt = 2 Then
                         r = "C"
                         Exit For
                     End If
                 End If
             Next
         End If
     Next
 End Sub 
（xyz） 2023/09/02(土) 14:48:56

 Sub test()
    Dim c As Range
    Dim a As String, f As String

    For Each c In Cells(1).CurrentRegion.Columns
        If WorksheetFunction.CountIf(c, "A") = 3 Then
            a = c.Address
            f = "IF(" _
                & "ROW(" & a & ")=SMALL(IF(" & a & "=""A"",ROW(" & a & "),10^7),2)," _
                & """C""," _
                & a & ")"
            c.Value = c.Parent.Evaluate(f)
        End If
    Next

 End Sub
（マナ） 2023/09/02(土) 21:17:50

白茶さん　xyzさん　マナさん　
同じ「列」の2番目のAを無事Cに変更することができました。3つの事例ともに勉強になりました。ありがとうございます。

引き続きの質問ですが、同じ「列」の2番目のAを同じ「行」の他の列のCと入れ替えるにはどのようしたらよいですか。

例）セルA4の「A」とセルC4の「C」を入れ替える

白茶さんのコードで

   Dim c As Range, r As Range, a As Range, i As Long
    For Each c In [A2:C12].Columns
        For Each r In c.Rows
            If r.Value = "A" Then i = i + 1
            If i = 3 Then Exit For
            If a Is Nothing Then If i = 2 Then Set a = r
        Next
　　　　If i = 3 Then a.Value =
まではイメージできたのですがその後、どのようにしたら良いか教えてください。

（メガネ） 2023/09/06(水) 00:48:37

 >同じ「行」の他の列
 例えば...

 ○aのふたつ右隣
     a.Offset(,2)
 ○C列のaと同じ行
     a.EntireRow.Columns(3)
 ○aの属する行とC列が交差するセル
     Intersect(a.EntireRow, Columns(3))

 みたいに表現方法は色々あります。
 そこが「C」だったら「入れ替える」という書き方になろうかと思います。

（白茶） 2023/09/06(水) 08:57:17

編集がかぶりしましたがそのまま。

横からですが、【他の列】とは具体的にどの列を指しますか？
最初の例示に従えば、【B列】も「同一列にAが3個」という条件を満たしていますが、【A列】と【C列】の組み合わせになる理由はありますか？

また、【A列】の2番目のAは、A6セルかとおもいますが、例示ミスですか？

（もこな２） 2023/09/06(水) 09:01:30

白茶さん　ありがとうございます。試してみます。
（メガネ） 2023/09/06(水) 09:20:36

もこな2さん　質問ありがとうございます。補足させていただきます。
他の列は、2番目のAがある列以外で同じ行にCがある列になります。
[A列]と[C列]の組み合わせになる理由はありません。
例示訂正　[A列]の2番目のAはA6セルになります。
例示ミスでした。失礼しました。

（メガネ） 2023/09/06(水) 09:36:12

そうなると↓みたいな感じでよいように思います

【処理条件】

 ・入替元セル：「 同じ列に"A"が３つある」and「上から２番目の"A"」
 ・入替先セル：「↑の【列より後ろ】」and「値が"C"」

【処理の流れ】

  1. 1列目から最後の列まで順番に見ていき
  2.    もしも「列にAが３つあるならば」
  3.       「上から２番目の"A"」の【セル】を覚える
  4.        ループを抜ける
  5.    もしもの話はおしまい
  6. 全部見終わったら終了

  7. もしも覚えた【セル】があったら
  8.　 覚えた【セル】の列+1から最後の列まで順番にみていき
  9.　     もしも「その列の覚えた【セル】の行」の値が"C"なら
 10.　　　　 「その列の覚えた【セル】の行」の値を"A"に書き換える
 11.　　　　 「覚えた【セル】」の値を"C"に書き換える
 12.　      ループを抜ける
 13.　　　 もしもの話はおしまい
 14.　 全部見終わったら終了
 15. もしもの話はおしまい

↑なら以下のようになるので目的が達成できると思います。

 【入替元セル】が見つからないとき・・・・7以降が実行されない
 【入替先セル】が見つからないとき・・・・10～12が実行されない

（もこな２） 2023/09/06(水) 12:07:07

もこな２さん　ありがとうございます。
「上から２番目の"A"」の【セル】を覚える
をコードで書くとどのような表記名なるか教えてください。
（メガネ） 2023/09/06(水) 16:27:58

 確認です。
 以下のケースでは結果はどうなるんですか？
 結果を示してください。

 各列で「Aが3個」というのはどのタイミングで判断しますか？
 前の列からAが移動してくることもあるわけで、
 ・動的に判断するんですか、
 ・それとも当初の状態で「Aが3個」を判断するんですか？
 上から2番目という判断も同じです。動的にするんですかね。

     A   B   C
 1   あ  い  う
 2   C   C   C
 3   C   A   C
 4   A   C   C
 5   C   C   C
 6   A   C   C
 7   C   A   C
 8   A   C   C
 9   C   C   A
 10  C   C   C
 11  C   C   A
 12  C   C   C

（xyz） 2023/09/06(水) 18:11:02

xyzさん　ご確認ありがとうございます。ご指摘のもと補足させていただきます。
当初の状態で「Aが3個」を判断します。
しかしご指摘のとおり、移動先の列のAが3個になってしまうことがあります。
移動先の条件を追加で、「Aの移動先の列はAが1個以下」にしないといけないことに気が付きました。
条件が定まっていなく失礼しました。よろしくお願いします。
（メガネ） 2023/09/06(水) 19:42:15

■１
＞【セル】を覚えるをコードで書くと～
やり方はいろいろあると思いますが、オブジェクト型の変数に格納するのがやりやすいと思います。

    Sub 研究用()
        Stop
        Dim MyRNG As Range

        If Not MyRNG Is Nothing Then
            MsgBox "覚えたセルは" & vbLf & _
                         "　ブック：" & MyRNG.Parent.Parent.Name & vbLf & _
                         "　シート：" & MyRNG.Parent.Name & vbLf & _
                         "　セル番地：" & MyRNG.Address(False, False) & vbLf & _
                         "です"
        End If

        Set MyRNG = ThisWorkbook.Worksheets(1).Range("A1")

        If Not MyRNG Is Nothing Then
            MsgBox "覚えたセルは" & vbLf & _
                         "　ブック：" & MyRNG.Parent.Parent.Name & vbLf & _
                         "　シート：" & MyRNG.Parent.Name & vbLf & _
                         "　セル番地：" & MyRNG.Address(False, False) & vbLf & _
                         "です"
        End If
    End Sub

■２
上記を踏まえて「2023/09/06(水) 12:07:07」の内容をコード化するとこんな感じです。

    Sub 研究用()
        Stop 'ブレークポイントの代わり
        Dim 行 As Long, 列 As Long
        Dim c As Long
        Dim MyRNG As Range

        With ActiveSheet
            For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If WorksheetFunction.CountIf(.Columns(列), "A") = 3 Then
                    For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
                        If .Cells(行, 列).Value = "A" Then
                            c = c + 1
                            If c = 2 Then
                                Set MyRNG = .Cells(行, 列)
                                Exit For
                            End If
                        End If
                    Next 行
                End If
                If Not MyRNG Is Nothing Then Exit For
            Next 列

            For 列 = MyRNG.Column + 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If .Cells(MyRNG.Row, 列).Value = "C" Then
                    .Cells(MyRNG.Row, 列).Value = "A"
                    MyRNG.Value = "C"
                    Exit For
                End If
            Next 列
        End With
    End Sub

 ※１　研究用として提供していますので、丸パクリして完成！というのはご遠慮ください。
 　　（興味があれば【ステップ実行】等により研究の上、必要な部分のみご自身のコードに組み込んでください）

 ※２　一回のみの処理であれば、上記のように【入替元セル】【入替先セル】それぞれを特定してから処理すればよいように思います。
 　　（そうじゃなくて、処理（入れ替え）後にも処理するならば、既に指摘があるように"どのタイミングで"判定するのか説明してください。）

（もこな２） 2023/09/06(水) 21:00:23

もこな２さん　コードのご提供ありがとうございます。
2023/09/06(水) 12:07:07の解説と照らし合わせ消化しています。
ステップ実行で追ってみたのですが入替えが実行されませんでした。
特にエラーにもならず終了していることから何か条件が違っているのでしょうか？

（メガネ） 2023/09/07(木) 09:49:59

↓を実行して、イミディエイトに何と出力されたか教えてください。

    Sub 検証用()
        Dim 行 As Long, 列 As Long
        Dim c As Long
        Dim srcRNG As Range, dstRNG As Range
        With ActiveSheet
            For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If WorksheetFunction.CountIf(.Columns(列), "A") = 3 Then
                    For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
                        If .Cells(行, 列).Value = "A" Then
                            c = c + 1
                            If c = 2 Then
                                Set srcRNG = .Cells(行, 列)
                                Exit For
                            End If
                        End If
                    Next 行
                End If
                If Not srcRNG Is Nothing Then Exit For
            Next 列

            If srcRNG Is Nothing Then
                Debug.Print " 入替元が見つかりませんでした"
            Else
                For 列 = srcRNG.Column + 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                    If .Cells(srcRNG.Row, 列).Value = "C" Then
                        Set dstRNG = .Cells(srcRNG.Row, 列)
                        Exit For
                    End If
                Next 列
            End If
        End With

        If dstRNG Is Nothing Then
            Debug.Print " 入替元：" & srcRNG.Address & vbTab & "入替先はみつかりませんでした"
        Else
            Debug.Print " 入替元：" & srcRNG.Address & vbTab & "入替先：" & dstRNG.Address
        End If
    End Sub

（もこな２） 2023/09/07(木) 12:38:30

同一シートに他の表がないことが前提で

Function 列範囲内で任意の位置のAが入力されているセルを返しなさい(ByVal 範囲 As Range, _

                                       Optional ByVal n番目 As Long = 1, _
                                       Optional ByVal 探し方 As Boolean = True) As Range

    '指定した数のAがなかったら終了
    Dim cnt As Long
    cnt = WorksheetFunction.CountIf(範囲, "A")
    If cnt < 3 Or cnt < n番目 Then Exit Function

    '昇順/降順でn番目にあるAが入力されているセルを返す
    Dim v As Variant
    Dim r As Long
    Dim sr As Long
    Dim er As Long
    Dim St As Long
    v = 範囲.Value
    Select Case 探し方
        Case True:  sr = 1:            er = UBound(v, 1):   St = 1  '昇順
        Case False: sr = UBound(v, 1): er = 1:              St = -1 '降順
    End Select
    cnt = 0
    For r = sr To er Step St
        If v(r, 1) = "A" Then cnt = cnt + 1 'Aの数を数える
        If cnt = n番目 Then Exit For        'n番目になったら終了
    Next r

    'n番目のAが入力されているセルを返す
    Set 列範囲内で任意の位置のAが入力されているセルを返しなさい = 範囲.Cells(r, 1)

End Function

Function 任意の行範囲内で直近のCが入力されているセルを返しなさい(ByVal 範囲 As Range) As Range

    '指定した行にCがなかったら終了
    Dim c As Long
    c = Application.Match("C", 範囲, 0)
    If IsError(c) Then Exit Function

    '直近のCが入力されているセルを返す
    Set 任意の行範囲内で直近のCが入力されているセルを返しなさい = 範囲.Cells(1, c)
End Function

Sub Sample()

    '
    Dim rng As Range
    Dim er As Long
    Dim ec As Long
    Set rng = Worksheets(該当シート名またはIndex).UsedRange '全体の範囲
    er = rng.Rows.Count                                     '行の長さ
    ec = rng.Columns.Count                                  '列の長さ

    '
    Dim 列範囲 As Range
    Dim 行範囲 As Range
    Dim A対象 As Range
    Dim C対象 As Range
    Dim c As Long
    Dim v As Variant
    For c = 0 To ec - 1
        Set 列範囲 = rng.Resize(1, er).Offset(0, c)
        Set A対象 = 列範囲内で任意の位置のAが入力されているセルを返しなさい(列範囲, 2)
        If Not A対象 Is Nothing Then
            'A対象のセルが返ってきていれば処理
            Set 行範囲 = rng.Cells(c + 1, 1).Resize(1, ec - c)
            Set C対象 = 任意の行範囲内で直近のCが入力されているセルを返しなさい(行範囲)
            If Not C対象 Is Nothing Then
                'C対象のセルが返って生きていれば処理
                v = A対象.Value
                A対象.Value = C対象.Value
                C対象.Value = v
            End If
        End If
    Next c
End Sub

こんな感じとかどうですか？

（ 'ふ'） 2023/09/07(木) 16:31:21

もこな２さん　イミディエイトに「入替元：$A$5 入替先：$C$5」と表示されました。
しかし$C$5は、「C」のままで、「A」とは入れ替わりませんでした。
（メガネ） 2023/09/08(金) 10:35:13

＞イミディエイトに「入替元：$A$5 入替先：$C$5」と表示されました。
うーん。謎ですね。
とりあえず、両方のセルは見つかっているようなので↓でどうでしょうか？

    Sub 別案()
        Dim 行 As Long, 列 As Long, c As Long
        Dim srcRNG As Range, dstRNG As Range
        Dim buf As Variant

        With ActiveSheet
            For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If WorksheetFunction.CountIf(.Columns(列), "A") = 3 Then
                    For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
                        If .Cells(行, 列).Value = "A" Then
                            c = c + 1
                            If c = 2 Then
                                Set srcRNG = .Cells(行, 列)
                                Exit For
                            End If
                        End If
                    Next 行
                End If
                If Not srcRNG Is Nothing Then Exit For
            Next 列

            If Not srcRNG Is Nothing Then
                For 列 = srcRNG.Column + 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                    If .Cells(srcRNG.Row, 列).Value = "C" Then
                        Set dstRNG = .Cells(srcRNG.Row, 列)
                        Exit For
                    End If
                Next 列
            End If
        End With

        If Not dstRNG Is Nothing Then
            buf = srcRNG.Value
            srcRNG.Value = dstRNG.Value
            dstRNG.Value = buf
        End If
    End Sub

（もこな２） 2023/09/08(金) 12:14:26

もこな２さん　ありがとうございます。

            buf = srcRNG.Value
            srcRNG.Value = dstRNG.Value
            dstRNG.Value = buf
これでいれかえてることを理解しました。
（メガネ） 2023/09/08(金) 15:29:55

もこな２さん　2023/09/08(金) 12:14:26にご提示いただいたコードで、
「A」移動先の「C」の列に「A」が無いという条件を追加したいのですが

 If Not srcRNG Is Nothing Then
ここをどのように変えたらよいか教えてください。
（メガネ） 2023/09/08(金) 17:43:51

提示されたコードで同じように3個あるか判定してますよね。
少しは自分で考えたらどうですか？
（苦言） 2023/09/08(金) 17:46:26

苦言さん　おっしゃるとおり　3個あるか判定している
　If WorksheetFunction.CountIf(.Columns(列), "A") = 3 Then　を

  If Not srcRNG Is Nothing Then　と入れ替えてみたのですが入替ができませんでした？
他にどこを変えたらよいか教えてください。

（メガネ） 2023/09/08(金) 18:14:48

  If Not srcRNG Is Nothing Then と入れ替えたのは
　If WorksheetFunction.CountIf(.Columns(列), "A") = 0 Then　でした。
失礼しました。
（メガネ） 2023/09/08(金) 18:17:03

ちょっとよくわからないので、【全体を提示】したうえで、【ステップ実行】したときに、どの箇所が実行されずに困っているか教えてください。

（もこな２） 2023/09/13(水) 08:43:56

書き忘れ

【入れ替え】と表現されていますが、↓は何しているか理解出来てますか？

 If Not srcRNG Is Nothing Then

それを取っ払ったらsrcRNGが見つかって無くとも処理が進んでしまうので、ちょっとマズくないですか？

箇所の【入れ替え】ならその限りでは無いですが、最終的な処理ができませんからdstRNGを探すだけ無駄になるので、もとの場所の方がよいとおもいます。

（もこな２） 2023/09/13(水) 08:58:17

＞「A」移動先の「C」の列に「A」が無いという条件を追加したい
残念ながら反応が無いですが、条件を追加ですから【入れ替える】のではなく【追加】しないとダメですよ。

    Sub 別案_改()
        Dim 行 As Long, 列 As Long, c As Long
        Dim srcRNG As Range, dstRNG As Range
        Dim buf As Variant

        With ActiveSheet
            For 列 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If WorksheetFunction.CountIf(.Columns(列), "A") = 3 Then
                    For 行 = 2 To .Cells(.Rows.Count, 列).End(xlUp).Row
                        If .Cells(行, 列).Value = "A" Then
                            c = c + 1
                            If c = 2 Then
                                Set srcRNG = .Cells(行, 列)
                                Exit For
                            End If
                        End If
                    Next 行
                End If
                If Not srcRNG Is Nothing Then Exit For
            Next 列

            If Not srcRNG Is Nothing Then
                For 列 = srcRNG.Column + 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                    【追加】もしも、列の"A"の個数が0より多ければ
                        If .Cells(srcRNG.Row, 列).Value = "C" Then
                            Set dstRNG = .Cells(srcRNG.Row, 列)
                            Exit For
                        End If
                    【追加】もしもの話はおしまい
                Next 列
            Else
                MsgBox "元が見つかりません"
            End If
        End With

        If Not dstRNG Is Nothing Then
            MsgBox "元・先どちらもみつかりました"
        Else
            MsgBox "元は見つかりましたが、先がみつかりません"
        End If
    End Sub

（もこな２） 2023/09/15(金) 07:54:12

コメント返信：

[ 一覧(最新更新順) ]

[[20230901145126]] 『マクロでセルの値変換』（メガネ） ページの最後に飛ぶ

[[20230901145126]]　『マクロでセルの値変換』（メガネ）　ページの最後に飛ぶ