1287488322 【Excel/VBA】についての質問です。


並び替えしている任意列の中で列方向同じ値のセルを結合するマクロをお願いします。

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2010/10/19 20:38:44
  • 終了:2010/10/21 19:07:03

ベストアンサー

id:Silvanus No.1

Silvanus回答回数174ベストアンサー獲得回数672010/10/19 21:24:03

ポイント70pt

こんな感じでいかがでしょうか。

"SelectCol"を実行して下さい。

マクロ実行時にセレクトされているセル(複数選択されている場合は一番右上のセル)の

列を処理の対象としています。

Option Explicit

Sub SelectCol()

    Hatena_pocon_101019 Selection.Column

End Sub

Sub Hatena_pocon_101019(lngCol As Long)

Dim lngRowLst As Long
Dim lngRowCnt As Long
Dim lngRowGrp As Long

lngRowLst = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRowCnt = 1
    Do
            If Application.CountA(Cells(lngRowCnt, lngCol)) > 0 Then
                lngRowGrp = lngRowCnt
                    Do While Cells(lngRowGrp, lngCol).Value _
                           = Cells(lngRowCnt + 1, lngCol).Value
                        lngRowCnt = lngRowCnt + 1
                    Loop
                Application.DisplayAlerts = False
                Range(Cells(lngRowGrp, lngCol), Cells(lngRowCnt, lngCol)).Merge
                Application.DisplayAlerts = True
            End If
        lngRowCnt = lngRowCnt + 1
    Loop Until lngRowCnt > lngRowLst

End Sub
id:pocon

アタシにゃ能力及ばず全くもって解析できませんでしたが

動作はバッチリでした。ありがとうございました。

2010/10/21 18:28:15

その他の回答(1件)

id:Silvanus No.1

Silvanus回答回数174ベストアンサー獲得回数672010/10/19 21:24:03ここでベストアンサー

ポイント70pt

こんな感じでいかがでしょうか。

"SelectCol"を実行して下さい。

マクロ実行時にセレクトされているセル(複数選択されている場合は一番右上のセル)の

列を処理の対象としています。

Option Explicit

Sub SelectCol()

    Hatena_pocon_101019 Selection.Column

End Sub

Sub Hatena_pocon_101019(lngCol As Long)

Dim lngRowLst As Long
Dim lngRowCnt As Long
Dim lngRowGrp As Long

lngRowLst = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRowCnt = 1
    Do
            If Application.CountA(Cells(lngRowCnt, lngCol)) > 0 Then
                lngRowGrp = lngRowCnt
                    Do While Cells(lngRowGrp, lngCol).Value _
                           = Cells(lngRowCnt + 1, lngCol).Value
                        lngRowCnt = lngRowCnt + 1
                    Loop
                Application.DisplayAlerts = False
                Range(Cells(lngRowGrp, lngCol), Cells(lngRowCnt, lngCol)).Merge
                Application.DisplayAlerts = True
            End If
        lngRowCnt = lngRowCnt + 1
    Loop Until lngRowCnt > lngRowLst

End Sub
id:pocon

アタシにゃ能力及ばず全くもって解析できませんでしたが

動作はバッチリでした。ありがとうございました。

2010/10/21 18:28:15
id:spyglass No.2

spyglass回答回数455ベストアンサー獲得回数292010/10/19 22:02:32

ポイント70pt

"macro"を実行してください。

x,y,zにはそれぞれ初期値を入れてくださいね。

=========== ここから以下macro ===============

Sub Macro()

x = 1: '横開始セル

y = 2: '縦開始セル

z = 14: '結合最終セル

Do

yy = 1

Do While Range(Cells(y, x), Cells(y, x)).Value = Range(Cells(y + yy, x), Cells(y + yy, x)).Value

Range(Cells(y + yy, x), Cells(y + yy, x)).Value = ""

yy = yy + 1

Loop

yy = yy - 1

Range(Cells(y, x), Cells(y + yy, x)).Select

Selection.MergeCells = True

y = y + yy + 1

Loop While z > y

Range("A1").Select

End Sub

id:pocon

なるほどなるほど。

勉強になります。ありがとうございました。

2010/10/21 19:06:10
  • id:Silvanus
    いるか賞ありがとうございます。お気付きかとは思いますが、説明文中の
    「一番右上のセル」は「一番左上のセル」が正しいです。済みません。
    簡単ですが、マクロの内容を解説させていただきます。
    ---
    Option Explicit
    '↑ 「変数は必ず定義して使用する(未定義の変数があればエラー)」
    ' マクロを勉強されている段階では必ず指定されることをお奨めします。
    Sub SelectCol()
    Hatena_pocon_101019 Selection.Column
    '↑ 実際の処理を行なっているルーティンを呼び出しています。
    ' 引数は処理を施したい列を数値(変数・定数)で指定します。
    ' Selection.columnは現在の選択範囲の最も左側の列の番号(A列=1、B列=2、…)を返します。
    ' 選択されているセルの列ではなく、特定の列について処理したい場合は、
    ' Selection.Columnをその列番号が入っている変数か定数(直に数値を入れても勿論OK)
    End Sub
    '
    Sub Hatena_pocon_101019(lngCol As Long)
    '↑ 引数lngColに処理をしたい列番号を受け取ります。
    '↓ 変数を宣言します。
    Dim lngRowLst As Long ' 全ての処理を終わらせる最後の行番号
    Dim lngRowCnt As Long ' 行番号のカウンタ
    Dim lngRowGrp As Long ' 値を下(行番号が増える)方向へ順にみていくとき、
                 ' その直上の行と異なる値が出現した時のlngRowCntの値を格納
    '
    lngRowLst = Cells.SpecialCells(xlCellTypeLastCell).Row
    '↑ 全ての処理を終わらせる最後の行として、SpecialCells(xlCellTypeLastCell)を
    ' 指定します。Cellsはシート内の全てのセルを指し、.Rowはその前に書かれている
    ' SpecialCells(xlCellTypeLastCell)の最も上側の行の番号を返します。
    ' SpecialCells(xlCellTypeLastCell)というのは、そのワークシート内で
    ' 編集履歴のある最も下/右にあるセルのことです。現在値が記入されているセルは
    ' 勿論ですが過去に値の記入や書式の変更を行なってそれが現在は消去されている
    ' セルも検出の対象になります。SpecialCells(xlCellTypeLastCell).Rowを
    ' 処理の最終行にすることによって、少なくとも取りこぼし(それより下の行に
    ' 未処理のデータが残った状態)はなくなります。ただ、処理を行なう列に限定して
    ' SpecialCells(xlCellTypeLastCell)を検出するのは恐らく無理で
    ' 飽くまでワークシート全体が対象になります(間違っていたらごめんなさい)。
    ' 少なくともColumns(1).SpecialCells(xlCellTypeLastCell).Rowと変更しても
    ' Cells.…とした場合と結果は全く変わりません。
    lngRowCnt = 1 '処理は1行目から始めますので行カウンタを1に設定します。
    Do ' 対応するLoop後にあるUntil以下の条件が成立するまでループします。(大きいループ)
    If Application.CountA(Cells(lngRowCnt, lngCol)) > 0 Then
    '↑ 行カウンタで示されるセルに値(数値・文字双方可)が入っていたらIf~End内を実行します。
    'If Not IsEmpty(cells(…)) Then と書いた方がスマートかも…。
    lngRowGrp = lngRowCnt '今の行カウンタをlngRowGrpに記憶します。
    Do While Cells(lngRowGrp, lngCol).Value _
    = Cells(lngRowCnt + 1, lngCol).Value
    '↑ 行カウンタ+1で示されるセルの値が、lngRowGrpで示されるセルの値と同じならば
    ' ループします。(小ループ)
    lngRowCnt = lngRowCnt + 1 ’行カウンタをひとつ増やします。
    Loop ' (小ループここまで)
    Application.DisplayAlerts = False
    '↑セルを結合する時、最も(左)上にある値以外は全て抹消されるため警告がでますが
    ' このお呪いをしておくと、警告が出ません。(他の例としては変更を加えたワークブックを
    ' マクロで強制的に警告無しに閉じたい時等)
    Range(Cells(lngRowGrp, lngCol), Cells(lngRowCnt, lngCol)).Merge
    '↑ lngRowGrpで指定される行から現在の行カウンタで指定される行までのセルを結合します。
    Application.DisplayAlerts = True
    '↑ 警告表示を再有効化します。
    End If
    lngRowCnt = lngRowCnt + 1
    '↑ 結合終了後(If~EndIf内実行)或いは空白のセルをスキップ(If~EndIf内不実行)した後の
    ' 行カウンタをひとつ増やします。
    Loop Until lngRowCnt > lngRowLst
    '↑ (大ループここまで) 行カウンタがlngRowLstよりも大きくなったらループを終了。
    End Sub
  • id:pocon
    >Silvanus 様

    詳細解説いただき、ありがとうございます。
    選択範囲の処理指定は汎用性があり使いやすいです。

    大変恐縮ですが、結合ではなく重複行が2行目以降の値を無し(="")にした場合の
    処理も必要になったのですが、記述は大幅に変わりますでしょうか?(新たにPOSTするべきでしょうか)
    上記画像でA2のみ123が入ってA3~A5は値無しというイメージです。

  • id:Silvanus
    こんにちは。
    (1) 上の画像と同じデータ配置
    (2) 但しA3~A5は空欄
    (3) 結果は従来のものと同じにしたい
    ということでしょうか?それとも
    (3’) 空欄行は空欄行同士で結合したい
    ということですか?、(3)/(3')のどちらでしょうか。
    いずれにしてましても、その程度なら簡単ですので
    本質問のコメント欄で対応させていただきますが、
    ただ、空欄行を処理の対象とすると、
    下端をどこの行まで処理の対象とすれば良いかが問題になってきます。
    一つの方法としては、処理範囲を予め選択(反転状態)しておくことで
    マクロに処理範囲を渡す、というのがありますね。
  • id:pocon

    私の拙い文章に詳細お心遣いいただき感謝しております。(o_ _)o
    結果は従来のものと同じにしたい(3)になるかと思います。
    ----

    +---
    |123
    +---

    +---

    +---

    +---
    |222
    +---
    |252
    +---

    +---
    下端につきましては、本質問(結合)もコメント(2つめ以降値無し)の件もご指摘の通り処理範囲を予め選択(反転)している中で
    処理を走らせる事できれば非常に使いやすく理想的です。(^^ゞ



  • id:Silvanus
    了解です。二点だけ確認を。
    [一点目]
    例えば、
    123
    123
    (空欄)
    (空欄)
    (空欄)
    234
    というケースが仮に出て来た場合、
    最初の5行を結合する、という処理でOKですか?
    [二点目]
    空欄行についての処理を、従来型(質問本文では処理の対象としなかった)と
    新たにご要望のタイプを切り換えて使用することがあるのか、或いは、
    後者に一本化して良いのか、どちらですか?
  • id:pocon
    従来仕様A、コメント仕様Bといたしまして、理想を申し上げれば

    [一点目]の件
    Aの処理
    +---

    |123

    +---
    |234
    +---

    Bの処理
    +---
    |123
    +---
    |空欄
    +---
    |空欄
    +---
    |空欄
    +---
    |空欄
    +---
    |234
    +---

    [二点目]の件
    別のところで、Bの処理が必要となり両方使いたいです。


  • id:Silvanus
    Bの処理の結果の方は、恐らく、正しくは
    123(2行結合)
    空欄
    空欄
    空欄
    234
    ですよね?空欄4行じゃないですよね?
    何れにしても了解いたしました。
    暫くお待ち下さい。
  • id:pocon
    Aは次のデータ1つ前(5行目)まで結合するのに対し
    Bは1行目だけデータを残してあとは空白とする
    結合は一切行わない形ですので、空欄4行です。


  • id:Silvanus
    あ、済みません。勘違いしていました(汗)。
    組み直しますので今暫くお待ちを。
  • id:Silvanus
    これでいけてますか?
    本来余り共通点の無いTypeAとTypeBの処理の内容を勘違いして
    共通点の多いものとして認識しマクロを組んでいたものを
    無理矢理修正したものですので甚だいびつなコードになっておりますが、
    動作自体は恐らく大丈夫だと思います。
    -----
    Option Explicit

    Sub MacroTypeB()

    Hatena_pocon_101108 True

    End Sub

    Sub MacroTypeA()

    Hatena_pocon_101108 False

    End Sub

    Sub Hatena_pocon_101108(blMode As Boolean)

    Dim lngRowLst As Long
    Dim lngRowCnt As Long
    Dim lngRowGrp As Long
    Dim lngCol As Long

    With Selection
    If .Columns.Count > 1 Or .Rows.Count < 2 Or .Areas.Count > 1 Then
    MsgBox Prompt:="範囲選択が不正です。", Title:="エラー"
    Exit Sub
    End If
    lngRowCnt = .Row
    lngRowLst = .Rows(.Rows.Count).Row
    lngCol = .Column
    End With

    Do
    If Not IsEmpty(Cells(lngRowCnt, lngCol)) Then
    lngRowGrp = lngRowCnt
    Do While (lngRowCnt < lngRowLst) And _
    ((Cells(lngRowGrp, lngCol).Value _
    = Cells(lngRowCnt + 1, lngCol).Value) Or _
    (IsEmpty(Cells(lngRowCnt + 1, lngCol)) And blMode))
    lngRowCnt = lngRowCnt + 1
    Loop
    If blMode Then
    If lngRowGrp < lngRowCnt Then
    Range(Cells(lngRowGrp + 1, lngCol), Cells(lngRowCnt, lngCol)).ClearContents
    End If
    Else
    Application.DisplayAlerts = False
    Range(Cells(lngRowGrp, lngCol), Cells(lngRowCnt, lngCol)).Merge
    Application.DisplayAlerts = True
    End If
    End If
    lngRowCnt = lngRowCnt + 1
    Loop Until lngRowCnt > lngRowLst

    End Sub
  • id:pocon
    ありがとうございます。
    True/Falseで処理を分岐するって方法も出来るんですね。
    すごいなぁ、シンプルで美しい。

    123
    123
    (空欄)
    (空欄)
    (空欄)
    234

    MacroTypeAで処理した場合

    123(5行結合)
    234



    123(2行結合)
    空欄
    空欄
    空欄
    234

    となります。
    そのような状況はまず無い(値なしのセルは無い)ので問題ないですけど。。
  • id:Silvanus
    あらら、また勘違いしてました…(汗)。
    これでOKでしょうか?
    本体部分のSubルーティンのみ示します。
    -----
    Sub Hatena_pocon_101108(blMode As Boolean)

    Dim lngRowLst As Long
    Dim lngRowCnt As Long
    Dim lngRowGrp As Long
    Dim lngCol As Long

    With Selection
    If .Columns.Count > 1 Or .Rows.Count < 2 Or .Areas.Count > 1 Then
    MsgBox Prompt:="範囲選択が不正です。", Title:="エラー"
    Exit Sub
    End If
    lngRowCnt = .Row
    lngRowLst = .Rows(.Rows.Count).Row
    lngCol = .Column
    End With

    Do
    If Not IsEmpty(Cells(lngRowCnt, lngCol)) Then
    lngRowGrp = lngRowCnt
    Do While (lngRowCnt < lngRowLst) And _
    ((Cells(lngRowGrp, lngCol).Value _
    = Cells(lngRowCnt + 1, lngCol).Value) Or _
    IsEmpty(Cells(lngRowCnt + 1, lngCol)))
    lngRowCnt = lngRowCnt + 1
    Loop
    If blMode Then
    If lngRowGrp < lngRowCnt Then
    Range(Cells(lngRowGrp + 1, lngCol), Cells(lngRowCnt, lngCol)).ClearContents
    End If
    Else
    Application.DisplayAlerts = False
    Range(Cells(lngRowGrp, lngCol), Cells(lngRowCnt, lngCol)).Merge
    Application.DisplayAlerts = True
    End If
    End If
    lngRowCnt = lngRowCnt + 1
    Loop Until lngRowCnt > lngRowLst

    End Sub
  • id:pocon

    完璧です。
    助かりました、本当にありがとうございました。
    こんなに良くしていただいたのに、ポイント差し上げられないのがツライです。orz
  • id:Silvanus
    いえいえ、また何かありましたら質問立てて下さいw。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません