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

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

新規登録して質問してみよう
ただいま回答率
85.51%
VBA

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

Q&A

解決済

6回答

7426閲覧

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

rx5rra

総合スコア27

VBA

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

0グッド

0クリップ

投稿2017/09/14 09:11

お世話になっております

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

置換前

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

置換後

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

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

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

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

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

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答6

0

例では、項目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
2A
3A×××
4A×××
5B

この場合、まずは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がループでないのが決め打ちで気に入らない感じですが、一応動きとしては要件は満たすのではないかと思います。(なんかこんな要件だけではない気がしてきた)

VBA

1 Dim i As Integer 2 Dim groupStartRow As Integer 3 Dim colGroup As Integer 4 5 i = 2 6 groupStartRow = 2 7 colGroup = 3 '3列ずつ処理する 8 9 Do While Range("A" & i).Value <> "" 10 If Range("A" & i).Value <> Range("A" & i + 1) Then 'グループの判定 11 Range(Range("A" & groupStartRow).Offset(0, 1), Range("A" & i).Offset(0, colGroup)).Select '項目1~3選択 12 Selection.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo 13 Range(Range("A" & groupStartRow).Offset(0, colGroup + 1), Range("A" & i).Offset(0, colGroup + colGroup)).Select '項目X~Z選択 14 Selection.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo 15 groupStartRow = i + 1 16 End If 17 i = i + 1 18 Loop 19

投稿2017/09/14 13:17

編集2017/09/14 15:56
kjml

総合スコア219

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

kikukiku

2017/09/15 00:27

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

2017/09/18 07:09

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

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/15 00:33

sazi

総合スコア25085

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

rx5rra

2017/09/18 00:40

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

2017/09/18 07:43

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

0

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

投稿2017/09/14 18:34

編集2017/09/14 18:38
kai_keitai

総合スコア344

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

rx5rra

2017/09/18 00:44

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

2017/09/18 00:48

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

0

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

以下の表を想定。

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

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

vba

1Option Explicit 2 3Sub main() 4 5Dim rangeValues() As Variant 6Dim startRow As Integer, lastRow As Integer 7Dim startColum As Integer, lastColum As Integer 8Dim dic() As Object 9Dim ii As Integer, jj As Integer, xx As Integer, yy As Integer, zz As Integer 10Dim groupSwitch As String 11Dim groupRows As Integer 12Dim values As Variant 13Dim startPoint As Range 14 15' 開始行、最終行 16startRow = 2 17lastRow = 6 18' 開始列、終了列 19startColum = 1 20lastColum = 7 21 22' 重複チェック用ディクショナリ初期化(列数分) 23ReDim dic(lastColum - startColum) 24For xx = 0 To lastColum - startColum 25 Set dic(xx) = CreateObject("Scripting.Dictionary") 26Next 27 28' 表全体の読み込み 29rangeValues = Range(Cells(startRow, startColum), Cells(lastRow, lastColum)).value 30 31' 表データ部分を一旦クリア 32Range(Cells(startRow, startColum + 1), Cells(lastRow, lastColum)).Clear 33 34' グループ行数初期化 35groupRows = 0 36' グループ切り替えチェック用 37groupSwitch = "" 38' 基準点設定(初回は表データ部分の左上) 39Set startPoint = Cells(startRow, startColum) 40 41For ii = 1 To UBound(rangeValues, 1) 42 If groupSwitch = "" Then 43 ' 初回は何もしない 44 ElseIf groupSwitch <> rangeValues(ii, 1) Then 45 ' 一つ前と異なる場合→グループ切り替わり時 46 ' 列マージ結果出力 @@@ 47 For xx = 0 To lastColum - startColum 48 ' 重複削除した分、行数が減るので調整 49 values = dic(xx).keys 50 ReDim Preserve values(groupRows - 1) 51 52 For yy = 0 To UBound(values) 53 startPoint.Offset(yy, xx).value = values(yy) 54 Next 55 dic(xx).RemoveAll 56 Next 57 58 '基準点を更新 59 Set startPoint = startPoint.Offset(groupRows, 0) 60 'グループ行数初期化 61 groupRows = 0 62 End If 63 64 65 ' グループ列を飛ばして(=2)ループ 66 For jj = 2 To UBound(rangeValues, 2) 67 If dic(jj - 2).Exists(rangeValues(ii, jj)) = False Then 68 dic(jj - 2).Add rangeValues(ii, jj), "" 69 End If 70 Next 71 72 ' グループ行数カウントアップ 73 groupRows = groupRows + 1 74 ' グループ名更新 75 groupSwitch = rangeValues(ii, 1) 76Next 77 78'最終グループの列マージ結果出力 @@@部分と全く同じ処理 79For xx = 0 To lastColum - startColum 80 ' 重複削除した分、行数が減るので調整 81 values = dic(xx).keys 82 ReDim Preserve values(groupRows - 1) 83 84 For yy = 0 To UBound(values) 85 startPoint.Offset(yy, xx).value = values(yy) 86 Next 87 dic(xx).RemoveAll 88Next 89 90End Sub 91

投稿2017/09/14 16:46

sa-yu

総合スコア201

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

rx5rra

2017/09/18 07:04

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

0

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

VBA

1Public Sub 行マージ() 2 Dim lastRow As Long 3 Dim lastColumn As Integer 4 lastRow = Range("A1048576").End(xlUp).Row '最終データ行 5 lastColumn = Range("XFD1").End(xlToLeft).Column '最終データ列 6 7 Dim targetGroup As String 8 Dim searchWord As Variant 9 Dim foundFlag As Boolean 10 targetGroup = Cells(2, 1) '検索対象のグループ 11 searchWord = Array("○", "△", "x") '検索文字列配列 12 foundFlag = False '検索文字列出現フラグ 13 14 Dim row_i As Integer 'イテレータ 行 15 Dim column_i As Long 'イテレータ 列 16 Dim search_i As Long 'イテレータ 検索文字列配列 17 Dim targetRange As Range '操作対象セル 18 19 For column_i = 2 To lastColumn 'テーブルを列方向に順に見ていく 20 For search_i = LBound(searchWord) To UBound(searchWord) '検索文字列配列を順に見ていく 21 For row_i = 2 To lastRow 'テーブルを行方向に順に見ていく 22 Set targetRange = Cells(row_i, column_i) 23 'targetRange.Select '処理の流れを見たい時はコメントを外し、ステップ実行してみて下さい。 24 If targetRange = searchWord(search_i) Then '検索文字列に合致するかどうか 25 If targetGroup = Cells(row_i, 1) Then '検索対象のグループと同じグループかどうか 26 If Not foundFlag Then 27 foundFlag = True '検索文字列の出現が1回目の場合はフラグを立てる 28 Else 29 Cells(row_i, column_i).ClearContents '検索文字列の出現が2回目以降の場合はセルの値を削除 30 If Cells(row_i, 1).Offset(1) = targetGroup Then '1行下のグループが検索対象のグループと同一の場合 31 targetRange = Cells(row_i, column_i).Offset(1) '1行下の値をセルに代入する 32 End If 33 End If 34 End If 35 End If 36 37 If targetGroup <> Cells(row_i, 1).Offset(1) Then 38 targetGroup = Cells(row_i, 1).Offset(1) '検索対象のグループを変更する 39 foundFlag = False '検索文字列出現フラグを初期化 40 End If 41 Next row_i 42 Next search_i 43 targetGroup = Cells(2, 1) '操作対象の列が変わったタイミングで、検索対象のグループを変更する 44 foundFlag = False '操作対象の列が変わったタイミングで、検索文字列出現フラグを初期化する 45 Next column_i 46End Sub

投稿2017/09/14 13:54

編集2017/09/14 14:06
zorac

総合スコア42

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

rx5rra

2017/09/18 07:06

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

0

ベストアンサー

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

置換前

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

追記

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

VBA

1Option Explicit 2 3Sub test() 4 Dim GStart As Integer 5 Dim GEnd As Integer 6 Dim RCount As Integer 7 Dim GName As String 8 9 RCount = 1 10 Do While True 11 GName = ActiveSheet.Cells(RCount, 1).Value 12 If GName = "" Then 13 Exit Do 14 End If 15 16 GStart = RCount 17 GEnd = グループ終端(GStart) 18 19 重複削除 GStart, GEnd, 2, 4 20 重複削除 GStart, GEnd, 5, 7 21 空白行詰 GStart, GEnd, 2, 4 22 空白行詰 GStart, GEnd, 5, 7 23 24 RCount = GEnd + 1 25 Loop 26End Sub 27 28Function グループ終端(GStart As Integer) As Integer 29 Dim RCount As Integer 30 Dim GName As String 31 32 RCount = GStart 33 GName = ActiveSheet.Cells(RCount, 1).Value 34 If GName = "" Then 35 グループ終端 = 0 36 Else 37 Do While True 38 If (ActiveSheet.Cells(RCount, 1).Value = GName) And (ActiveSheet.Cells(RCount + 1, 1).Value <> GName) Then 39 グループ終端 = RCount 40 Exit Do 41 End If 42 RCount = RCount + 1 43 Loop 44 End If 45End Function 46 47Sub 重複削除(GStart As Integer, GEnd As Integer, ColStart As Integer, ColEnd As Integer) 48 Debug.Print "===========" 49 Dim i As Integer 50 Dim iEnd As Integer 51 Dim j As Integer 52 Dim jStart As Integer 53 Dim col As Integer 54 Dim 一致 As Boolean 55 56 iEnd = GEnd - 1 57 If iEnd = GStart Then 58 Exit Sub 59 End If 60 61 For i = GStart To iEnd 62 jStart = GStart + 1 63 If jStart > GEnd Then 64 Exit For 65 End If 66 67 一致 = True 68 For col = ColStart To ColEnd 69 If ActiveSheet.Cells(i, col).Value = "" Then 70 Else 71 一致 = False 72 Exit For 73 End If 74 Next col 75 If 一致 Then 76 GoTo tobashi 77 End If 78 79 For j = jStart To GEnd 80 If i = j Then 81 Else 82 Debug.Print i, j 83 一致 = True 84 For col = ColStart To ColEnd 85 If ActiveSheet.Cells(i, col).Value = ActiveSheet.Cells(j, col).Value Then 86 Else 87 一致 = False 88 Exit For 89 End If 90 Next col 91 If 一致 Then 92 For col = ColStart To ColEnd 93 ActiveSheet.Cells(j, col).Value = "" 94 Next col 95 End If 96 End If 97 Next j 98tobashi: 99 Next i 100End Sub 101 102Sub 空白行詰(GStart As Integer, GEnd As Integer, ColStart As Integer, ColEnd As Integer) 103End Sub

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

置換前

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

VBA

1Option Explicit 2 3Sub test2() 4 Dim GStart As Integer 5 Dim GEnd As Integer 6 Dim RCount As Integer 7 Dim GName As String 8 9 RCount = 1 10 Do While True 11 GName = ActiveSheet.Cells(RCount, 1).Value 12 If GName = "" Then 13 Exit Do 14 End If 15 16 GStart = RCount 17 GEnd = グループ終端(GStart) 18 19 ActiveSheet.Range(ActiveSheet.Cells(GStart, 2), ActiveSheet.Cells(GEnd, 4)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo 20 ActiveSheet.Range(ActiveSheet.Cells(GStart, 5), ActiveSheet.Cells(GEnd, 7)).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo 21 22 RCount = GEnd + 1 23 Loop 24End Sub 25 26Function グループ終端(GStart As Integer) As Integer 27 Dim RCount As Integer 28 Dim GName As String 29 30 RCount = GStart 31 GName = ActiveSheet.Cells(RCount, 1).Value 32 If GName = "" Then 33 グループ終端 = 0 34 Else 35 Do While True 36 If (ActiveSheet.Cells(RCount, 1).Value = GName) And (ActiveSheet.Cells(RCount + 1, 1).Value <> GName) Then 37 グループ終端 = RCount 38 Exit Do 39 End If 40 RCount = RCount + 1 41 Loop 42 End If 43End Function

投稿2017/09/14 09:25

編集2017/09/15 00:50
kikukiku

総合スコア514

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

rx5rra

2017/09/14 09:28

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

2017/09/15 00:52

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

2017/09/18 07:10

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

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.51%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問