質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.61%

  • VBA

    1720questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1466questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

Excel VBA 特定範囲の重複している列に空白を設定する

解決済

回答 6

投稿

  • 評価
  • クリップ 0
  • VIEW 1,229

rx5rra

score 8

お世話になっております

EXCELのVBAや関数を使用し、下記の様な表を編集したいと思っております。

置換前

グループ 項目1* 項目2 項目3 項目X 項目Y 項目Z
A
A x x x
A x x x
B
C

置換後

グループ 項目1* 項目2 項目3 項目X 項目Y 項目Z
A
A x x x
A            
B
C

上記表の様に指定の範囲、
(グループAの項目1~3までの範囲)
(グループAの項目X~Zまでの範囲)
などそれぞれに対してそれぞれ重複の部分をブランクにして上に詰めたいです。
(この場合項目1~3は○が重複、X~Zはxが重複しているのでそれぞれ空白で埋めて上に詰める)
そして同じようにB、Cとループさせて行きたいのですが、上手く行きません。
行を削除せず、セルを範囲でブランクにするところが難しいと思うのですが、何か方法がございますでしょうか?

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 6

+1

例では、項目1~3や項目X~Zが3項目ずつ同じ値となる例しかないので、
それらがバラバラだった場合にはどうなってほしいのかわかりませんが、
それぞれの範囲に対してRemoveDuplicatesを使うのはどうでしょう?

(範囲のRangeオブジェクト).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

Columns:=はその範囲内のどの列の重複を基準に削除するか(上記の場合は3列すべてを対象としている)
Header:= はその範囲内の最初の行を項目名として扱うかどうかです。

あとは、それぞれの範囲を順に回していくだけです。

A列 B列 C列 D列 E列 F列 G列
1 グループ 項目1 項目2 項目3 項目X 項目Y 項目Z
2 A
3 A × × ×
4 A × × ×
5 B

この場合、まずはB2~D4を範囲にとって
range("B2:D4").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNoとしてみてください。
挙動がわかると思います。(あとは順次Aグループ残りのE2:G4,その次はBグループへ)

3項目ずつ同じではなくバラバラだった場合でも、Columns:=の指定の仕方や、範囲の取り方(同じグループで1列ずつ範囲を取るとか)で対応可能だと思います。

追記:
3列ずつのArrayのところと、項目1~3と項目X~Zがループでないのが決め打ちで気に入らない感じですが、一応動きとしては要件は満たすのではないかと思います。(なんかこんな要件だけではない気がしてきた)

    Dim i As Integer
    Dim groupStartRow As Integer
    Dim colGroup As Integer

    i = 2
    groupStartRow = 2
    colGroup = 3    '3列ずつ処理する

    Do While Range("A" & i).Value <> ""
        If Range("A" & i).Value <> Range("A" & i + 1) Then    'グループの判定
            Range(Range("A" & groupStartRow).Offset(0, 1), Range("A" & i).Offset(0, colGroup)).Select   '項目1~3選択
            Selection.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
            Range(Range("A" & groupStartRow).Offset(0, colGroup + 1), Range("A" & i).Offset(0, colGroup + colGroup)).Select '項目X~Z選択
            Selection.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
            groupStartRow = i + 1
        End If
        i = i + 1
    Loop

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/15 09:27

    RemoveDuplicatesな命令があるんですね。初めて知りました。大変勉強になりました。

    キャンセル

  • 2017/09/18 16:09

    ご回答ありがとうございます。
    RemoveDuplicates自体は知っていたのですが、行の削除しかできないと勘違いしていました・・・。
    わかりやすく説明して下さりありがとうございます

    キャンセル

checkベストアンサー

0

答えではありません。
置換前が下記であった場合、どのような結果になることを望んでいるのでしょうか?

置換前

グループ 項目1 項目2 項目3 項目X 項目Y 項目Z
A
A × × ×
A

追記

途中で力つきまして、空白行を詰める処置が入っていませんが
あとは頑張ってみてください。
ソースはかなりベタな感じですが、一応それ以外は動いています。

Option Explicit

Sub test()
    Dim GStart As Integer
    Dim GEnd As Integer
    Dim RCount As Integer
    Dim GName As String

    RCount = 1
    Do While True
        GName = ActiveSheet.Cells(RCount, 1).Value
        If GName = "" Then
            Exit Do
        End If

        GStart = RCount
        GEnd = グループ終端(GStart)

        重複削除 GStart, GEnd, 2, 4
        重複削除 GStart, GEnd, 5, 7
        空白行詰 GStart, GEnd, 2, 4
        空白行詰 GStart, GEnd, 5, 7

        RCount = GEnd + 1
    Loop
End Sub

Function グループ終端(GStart As Integer) As Integer
    Dim RCount As Integer
    Dim GName As String

    RCount = GStart
    GName = ActiveSheet.Cells(RCount, 1).Value
    If GName = "" Then
        グループ終端 = 0
    Else
        Do While True
            If (ActiveSheet.Cells(RCount, 1).Value = GName) And (ActiveSheet.Cells(RCount + 1, 1).Value <> GName) Then
                グループ終端 = RCount
                Exit Do
            End If
            RCount = RCount + 1
        Loop
    End If
End Function

Sub 重複削除(GStart As Integer, GEnd As Integer, ColStart As Integer, ColEnd As Integer)
    Debug.Print "==========="
    Dim i As Integer
    Dim iEnd As Integer
    Dim j As Integer
    Dim jStart As Integer
    Dim col As Integer
    Dim 一致 As Boolean

    iEnd = GEnd - 1
    If iEnd = GStart Then
        Exit Sub
    End If

    For i = GStart To iEnd
        jStart = GStart + 1
        If jStart > GEnd Then
            Exit For
        End If

        一致 = True
        For col = ColStart To ColEnd
            If ActiveSheet.Cells(i, col).Value = "" Then
            Else
                一致 = False
                Exit For
            End If
        Next col
        If 一致 Then
            GoTo tobashi
        End If

        For j = jStart To GEnd
            If i = j Then
            Else
                Debug.Print i, j
                一致 = True
                For col = ColStart To ColEnd
                    If ActiveSheet.Cells(i, col).Value = ActiveSheet.Cells(j, col).Value Then
                    Else
                        一致 = False
                        Exit For
                    End If
                Next col
                If 一致 Then
                    For col = ColStart To ColEnd
                        ActiveSheet.Cells(j, col).Value = ""
                    Next col
                End If
            End If
        Next j
tobashi:
    Next i
End Sub

Sub 空白行詰(GStart As Integer, GEnd As Integer, ColStart As Integer, ColEnd As Integer)
End Sub

追記:RemoveDuplicatesを使って書き換え。すべての機能実現

置換前

A列 B列 C列 D列 E列 F列 E列
1行 A
2行 A × × ×
3行 A × × ×
4行 B
5行 C
Option Explicit

Sub test2()
    Dim GStart As Integer
    Dim GEnd As Integer
    Dim RCount As Integer
    Dim GName As String

    RCount = 1
    Do While True
        GName = ActiveSheet.Cells(RCount, 1).Value
        If GName = "" Then
            Exit Do
        End If

        GStart = RCount
        GEnd = グループ終端(GStart)

        ActiveSheet.Range(ActiveSheet.Cells(GStart, 2), ActiveSheet.Cells(GEnd, 4)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
        ActiveSheet.Range(ActiveSheet.Cells(GStart, 5), ActiveSheet.Cells(GEnd, 7)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

        RCount = GEnd + 1
    Loop
End Sub

Function グループ終端(GStart As Integer) As Integer
    Dim RCount As Integer
    Dim GName As String

    RCount = GStart
    GName = ActiveSheet.Cells(RCount, 1).Value
    If GName = "" Then
        グループ終端 = 0
    Else
        Do While True
            If (ActiveSheet.Cells(RCount, 1).Value = GName) And (ActiveSheet.Cells(RCount + 1, 1).Value <> GName) Then
                グループ終端 = RCount
                Exit Do
            End If
            RCount = RCount + 1
        Loop
    End If
End Function

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/14 18:28

    表になるかわかりませんが下記のように、項目1~3の3行目だけがブランクになるイメージです
    |グループ|項目1|項目2|項目3|項目X|項目Y|項目Z|
    A|○|○|○|○|○|○
    A|△|△|△|×|×|×
    A| | | |△|△|△

    キャンセル

  • 2017/09/15 09:52

    一番したに追記したものが、一応ご要望の機能を実装したコードになります。kjmlさんから紹介のあったRemoveDuplicates命令を使うことで簡略化しています。

    キャンセル

  • 2017/09/18 16:10

    ご回答ありがとうございます。
    一番目的に達するのに近かったのでBAさせて頂きました。

    キャンセル

0

要件を満たしているのかどうか分かりませんが、提示された条件を満たすコードにはなっています。
自分でもびっくりすぐらい分かりにくいコードで申し訳ありません。
'targetRange.Select をアンコメントして、ステップ実行してもらえれば
どういう処理をしているのかは分かると思います。

Public Sub 行マージ()
    Dim lastRow As Long
    Dim lastColumn As Integer
    lastRow = Range("A1048576").End(xlUp).Row            '最終データ行
    lastColumn = Range("XFD1").End(xlToLeft).Column      '最終データ列

    Dim targetGroup As String
    Dim searchWord As Variant
    Dim foundFlag As Boolean
    targetGroup = Cells(2, 1)               '検索対象のグループ
    searchWord = Array("○", "△", "x")     '検索文字列配列
    foundFlag = False                       '検索文字列出現フラグ

    Dim row_i As Integer       'イテレータ 行
    Dim column_i As Long       'イテレータ 列
    Dim search_i As Long       'イテレータ 検索文字列配列
    Dim targetRange As Range   '操作対象セル

    For column_i = 2 To lastColumn                               'テーブルを列方向に順に見ていく
        For search_i = LBound(searchWord) To UBound(searchWord)  '検索文字列配列を順に見ていく
            For row_i = 2 To lastRow                             'テーブルを行方向に順に見ていく
                Set targetRange = Cells(row_i, column_i)
                'targetRange.Select                              '処理の流れを見たい時はコメントを外し、ステップ実行してみて下さい。
                If targetRange = searchWord(search_i) Then       '検索文字列に合致するかどうか
                    If targetGroup = Cells(row_i, 1) Then        '検索対象のグループと同じグループかどうか
                        If Not foundFlag Then
                            foundFlag = True                     '検索文字列の出現が1回目の場合はフラグを立てる
                        Else
                            Cells(row_i, column_i).ClearContents                   '検索文字列の出現が2回目以降の場合はセルの値を削除
                            If Cells(row_i, 1).Offset(1) = targetGroup Then      '1行下のグループが検索対象のグループと同一の場合
                                targetRange = Cells(row_i, column_i).Offset(1)   '1行下の値をセルに代入する
                            End If
                        End If
                    End If
                End If

                If targetGroup <> Cells(row_i, 1).Offset(1) Then
                    targetGroup = Cells(row_i, 1).Offset(1)           '検索対象のグループを変更する
                    foundFlag = False                                 '検索文字列出現フラグを初期化
                End If
            Next row_i
        Next search_i
        targetGroup = Cells(2, 1)    '操作対象の列が変わったタイミングで、検索対象のグループを変更する
        foundFlag = False            '操作対象の列が変わったタイミングで、検索文字列出現フラグを初期化する
    Next column_i
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/18 16:06

    ご回答ありがとうございます。
    私の説明が悪くて申し訳ないのですが、表中に出現する文字のパターンは大量にあるので略して○△☓で表現しておりました。

    キャンセル

0

こんなのはどうでしょう。

以下の表を想定。

      A列        B列        C列     D列     E列     F列     G列   
 1     グループ   項目1   項目2   項目3   項目X   項目Y   項目Z 
 2     A          ○       ○       ○       ○       ○       ○     
 3     A          ○       ○       ○       ×       ×       ×     
 4     A          △       △       △       ×       ×       ×     
 5     B          ○       ○       ○       ○       ○       ○     
 6     C          ○       ○       ○       ○       ○       ○     

一旦表全体を2次元配列として読み込んでしまってから、表をクリア。
グループ-列単位で重複チェックしながら、グループの切り替わりで、表出力。

Option Explicit

Sub main()

Dim rangeValues() As Variant
Dim startRow As Integer, lastRow As Integer
Dim startColum As Integer, lastColum As Integer
Dim dic() As Object
Dim ii As Integer, jj As Integer, xx As Integer, yy As Integer, zz As Integer
Dim groupSwitch As String
Dim groupRows As Integer
Dim values As Variant
Dim startPoint As Range

' 開始行、最終行
startRow = 2
lastRow = 6
' 開始列、終了列
startColum = 1
lastColum = 7

' 重複チェック用ディクショナリ初期化(列数分)
ReDim dic(lastColum - startColum)
For xx = 0 To lastColum - startColum
    Set dic(xx) = CreateObject("Scripting.Dictionary")
Next

' 表全体の読み込み
rangeValues = Range(Cells(startRow, startColum), Cells(lastRow, lastColum)).value

' 表データ部分を一旦クリア
Range(Cells(startRow, startColum + 1), Cells(lastRow, lastColum)).Clear

' グループ行数初期化
groupRows = 0
' グループ切り替えチェック用
groupSwitch = ""
' 基準点設定(初回は表データ部分の左上)
Set startPoint = Cells(startRow, startColum)

For ii = 1 To UBound(rangeValues, 1)
    If groupSwitch = "" Then
        ' 初回は何もしない
    ElseIf groupSwitch <> rangeValues(ii, 1) Then
        ' 一つ前と異なる場合→グループ切り替わり時
        ' 列マージ結果出力 @@@
        For xx = 0 To lastColum - startColum
            ' 重複削除した分、行数が減るので調整
            values = dic(xx).keys
            ReDim Preserve values(groupRows - 1)

            For yy = 0 To UBound(values)
                startPoint.Offset(yy, xx).value = values(yy)
            Next
            dic(xx).RemoveAll
        Next

        '基準点を更新
        Set startPoint = startPoint.Offset(groupRows, 0)
        'グループ行数初期化
        groupRows = 0
    End If


    ' グループ列を飛ばして(=2)ループ
    For jj = 2 To UBound(rangeValues, 2)
        If dic(jj - 2).Exists(rangeValues(ii, jj)) = False Then
            dic(jj - 2).Add rangeValues(ii, jj), ""
        End If
    Next

    ' グループ行数カウントアップ
    groupRows = groupRows + 1
    ' グループ名更新
    groupSwitch = rangeValues(ii, 1)
Next

'最終グループの列マージ結果出力 @@@部分と全く同じ処理
For xx = 0 To lastColum - startColum
    ' 重複削除した分、行数が減るので調整
    values = dic(xx).keys
    ReDim Preserve values(groupRows - 1)

    For yy = 0 To UBound(values)
        startPoint.Offset(yy, xx).value = values(yy)
    Next
    dic(xx).RemoveAll
Next

End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/18 16:04

    ご回答ありがとうございます。
    削除したセルの分だけ上に詰めるのをこんな表現でも解決できるのは驚きです。

    キャンセル

0

皆さんの回答のように、このような処理は、複雑なアルゴリズムを考えて、プログラムを実装しなければいけません。
私でしたら、データを全て配列で取り込んで、ループ処理を幾度も重ねることを考えます。そのコードは複雑な物になります。
もし、Accessの動作環境があるのなら、Accessでデータを作成したら?と思います。簡単なクエリを3個程度作れば、望んだデータを作成することが可能です。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/18 09:44

    ご回答ありがとうございます。
    その発想はありませんでした、Accessで出来ないか色々試して見たいと思います。

    キャンセル

  • 2017/09/18 09:48

    サンプルのエクセルでは、キー項目が無いので、行番号などのキーを付けてから、Accessで処理すると良いと思います。

    キャンセル

0

excel2010以降なら、Power Queryが使えそうです。
excel2016は標準機能ですけど、それ以外のバージョンは別途インストールが必要です。
https://www.microsoft.com/ja-jp/download/details.aspx?id=39379

以下は使い方的なサイトです。
テーブル (Power Query) の行をグループ化
ExcelでPowerQueryを使ってデータ収集分析

Power Queryではなく自前で行うならこちら。
Excelの集計をSQLでおこなう方法。

何れにしても、出力したものを入力と差し替えることが必要なら、その部分は実装が必要ですけど。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/09/18 09:40

    ご回答ありがとうございます。
    こういうものもあるのですね、知りませんでした。
    ただ今の環境では自由なインストールが出来ないので諦めるしかありませんが、今後Office2016を使い始めたときに良さそうです

    キャンセル

  • 2017/09/18 16:43

    「Excelの集計をSQLでおこなう方法。」であればインストールは不要です。
    良い回答は付いているみたいですから、もっと自由度が必要な際は参考に。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.61%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

  • VBA

    1720questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1466questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。