プロが教える店舗＆オフィスのセキュリティ対策術

同じ文字の入ったセルを確認して、別セルの文字を一つにまとめたい

解決済

  • 質問者：poppoyaya
  • 質問日時：
  • 回答数：11件

同じ文字の入ったセルを確認して、別セルの文字を一つにまとめたいのですが可能でしょうか？
関数では無理でしょうか？無理であればマクロでも構いませんので構文をご教授お願い致します。

例として下記データ(文字は例として挙げただけなので、文字数とかばらばらです）があります。
　　D列　　　E列　　F列
3　あああ　　a
4　いいい　　b
5　あああ　　c
6　ううう　　d
7　いいい　　e
8　いいい　　f
9　あああ　　g
10 えええ　　h

D列で同じ文字がある場合、同じ文字ごとにE列の文字をF列に[,]区切りでまとめたいです。
　　D列　　　E列　　F列
3　あああ　　a　　　a,c,g
4　いいい　　b　　　b,e,f
5　あああ　　c　　　a,c,g
6　ううう　　d　　　d
7　いいい　　e　　　b,e,f
8　いいい　　f　　　b,e,f
9　あああ　　g　　　a,c,g
10 えええ　　h　　　h

分かりにくくて申し訳ございません。

質問者からの補足コメント

  • ありがとうございます。
    すみません。大事な事を書くのを忘れていました。
    E列に重複データがある場合があります。
    それはひとつで表示したいです。
    申し訳ございません。

    例
    　　D列　　　E列　　F列
    3　あああ　　a
    4　いいい　　f
    5　あああ　　a
    6　ううう　　d
    7　いいい　　e
    8　いいい　　f
    9　あああ　　g
    10 えええ　　h

    ↓

    　　D列　　　E列　　F列
    3　あああ　　a　　　a,g
    4　いいい　　b　　　e,f
    5　あああ　　c　　　a,g
    6　ううう　　d　　　d
    7　いいい　　e　　　e,f
    8　いいい　　f　　　e,f
    9　あああ　　g　　　a,g
    10 えええ　　h　　　h

    No.1の回答に寄せられた補足コメントです。 補足日時：2019/05/16 20:16
    通報する
通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (11件中1～10件)

参考程度に

No.11

  • 回答者： 30246kiku
  • 回答日時：

以下でどうなりますか




Public Sub Samp1()
　　Dim dic As Object
　　Dim vA As Variant
　　Dim i As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　With Range("D3", Cells(Rows.Count, "D").End(xlUp))
　　　　vA = .Resize(, 2).Value

　　　　For i = 1 To UBound(vA)
　　　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　　　dic.Add vA(i, 1), CreateObject("Scripting.Dictionary")
　　　　　　End If
　　　　　　dic(vA(i, 1))(vA(i, 2)) = Empty
　　　　Next

　　　　For i = 1 To UBound(vA)
　　　　　　vA(i, 1) = Join(dic(vA(i, 1)).Keys, ",")
　　　　Next

　　　　.EntireRow.Columns("F").Value = vA
　　End With

　　Set dic = Nothing
End Sub
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
重複されることなく処理される事確認出来ました。

通報する
お礼日時：2019/05/23 16:04

No.10

No.9です。

数式でも良かったのですね？作業列を使っても良いですか？もし、良いのであればこんな感じです。次の数式を設定して、下へオートフィルしてください。
ちなみに、1000行までしか対応していません。

【F3セル】=VLOOKUP(D3,D:G,4,FALSE)
【G3セル】=IFERROR(IF(COUNTIFS(D4:D$1000,D3,E4:E$1000,E3)=0,E3&",","")&VLOOKUP(D3,D4:G$1000,4,FALSE),E3)
「同じ文字の入ったセルを確認して、別セルの」の回答画像10
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
作業列使う事で関数で対応出来る事確認出来ました。

通報する
お礼日時：2019/05/23 16:02

No.9

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



Sub sample()
Dim myRng As Range
Dim r As Range
Set myRng = Range("F3:F" & Cells(Rows.Count, "D").End(xlUp).Row)
myRng.Formula = "=IFERROR(IF(COUNTIFS(D4:D$1000,D3,E4:E$1000,E3)=0,E3&"","","""")&VLOOKUP(D3,D4:F$1000,3,FALSE),E3)"
For Each r In myRng
r.Value = WorksheetFunction.VLookup(r.Offset(0, -2).Value, Range("D:F"), 3, False)
Next r
End Sub
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
E列の内容がF列にそのままコピーされただけの結果になってしまいました。

通報する
お礼日時：2019/05/23 15:57

No.8

  • 回答者： fujillin
  • 回答日時：

こんにちは



すでに回答は出ているようですが、別法でのVBAです。

文字の連結は出現順（＝行番号が小さい方から）におこないます。
（補足でご例示の「e,f」は「f,e」の順になります）

Sub Sample()
Dim rng As Range, c As Range
Dim ct As Range, cu As Range
Dim s As String

Set rng = Range(Cells(3, 4), Cells(Rows.Count, 4).End(xlUp))
rng.Offset(, 2).FormulaLocal = "=IF(COUNTIFS($D$3:D3,D3,$E$3:E3,E3)=1,1,"""")"

For Each c In rng
If c.Offset(, 2).HasFormula Then
　s = ""
　Set ct = rng.Find(c.Value, lookat:=xlWhole)
　Set ct = c
　Set cu = c.Offset(, 2)
　Do
　　If ct.Offset(, 2).Value = 1 Then s = s & "," & ct.Offset(, 1).Value
　　Set cu = Union(cu, ct.Offset(, 2))
　　Set ct = rng.FindNext(ct)
　Loop While ct.Row > c.Row
　cu.Value = Mid(s, 2)
End If
Next c

End Sub
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございました。
重複されることなく処理される事確認出来ました。

通報する
お礼日時：2019/05/23 15:53

参考程度に

No.7ベストアンサー

  • 回答者： tom04
  • 回答日時：

No.1・5・6です。



No.6の最後に記載した、「注意点」も考慮してみました。

No.6のコードは消去し、↓のコードにしてみてください。

Sub Sample3()
　Dim myDic As Object
　Dim i As Long, k As Long, lastRow As Long
　Dim myFlg As Boolean
　Dim myR, myAry

　　Set myDic = CreateObject("Scripting.Dictionary")
　　lastRow = Cells(Rows.Count, "D").End(xlUp).Row
　　　myR = Range(Cells(3, "D"), Cells(lastRow, "F"))
　　　　For i = 1 To UBound(myR, 1)
　　　　　If Not myDic.exists(myR(i, 1)) Then
　　　　　　myDic.Add myR(i, 1), myR(i, 2)
　　　　　Else
　　　　　　myAry = Split(myDic(myR(i, 1)), ",")
　　　　　　　For k = 0 To UBound(myAry)
　　　　　　　　If myAry(k) = myR(i, 2) Then
　　　　　　　　　myFlg = True
　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　Next k
　　　　　　　　If myFlg = False Then
　　　　　　　　　myDic(myR(i, 1)) = myDic(myR(i, 1)) & "," & myR(i, 2)
　　　　　　　　End If
　　　　　End If
　　　　　　myFlg = False
　　　　Next i
　　　　For i = 1 To UBound(myR, 1)
　　　　　If myDic.exists(myR(i, 1)) Then
　　　　　　myR(i, 3) = myDic(myR(i, 1))
　　　　　End If
　　　　Next i
　　　Range(Cells(3, "D"), Cells(lastRow, "F")) = myR
　　　　Set myDic = Nothing
　　　　Range("F:F").Columns.AutoFit
　　　MsgBox "完了"
End Sub

おそらく、E列の文字数に関係なく重複分も処理されると思います。m(_ _)m
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございました。
重複されることなく処理出来ている事確認出来ました。

通報する
お礼日時：2019/05/23 14:56

うーん・・・

No.6

  • 回答者： tom04
  • 回答日時：

No.1・5です。



投稿後・・・
もしかしてこういうコトをご希望なのかな？と思ってコードを考えてみました。

Sub Sample2()
　Dim myDic As Object
　Dim i As Long, lastRow As Long
　Dim myR

　　Set myDic = CreateObject("Scripting.Dictionary")
　　lastRow = Cells(Rows.Count, "D").End(xlUp).Row
　　　myR = Range(Cells(3, "D"), Cells(lastRow, "F"))
　　　　For i = 1 To UBound(myR, 1)
　　　　　If Not myDic.exists(myR(i, 1)) Then
　　　　　　myDic.Add myR(i, 1), myR(i, 2)
　　　　　Else
　　　　　　If InStr(myDic(myR(i, 1)), myR(i, 2)) = 0 Then
　　　　　　　myDic(myR(i, 1)) = myDic(myR(i, 1)) & "," & myR(i, 2)
　　　　　　End If
　　　　　End If
　　　　Next i
　　　　For i = 1 To UBound(myR, 1)
　　　　　If myDic.exists(myR(i, 1)) Then
　　　　　　myR(i, 3) = myDic(myR(i, 1))
　　　　　End If
　　　　Next i
　　　Range(Cells(3, "D"), Cells(lastRow, "F")) = myR
　　　　Set myDic = Nothing
　　　　Range("F:F").Columns.AutoFit
　　　MsgBox "完了"
End Sub

こんな感じですかね？

※　注意点として　※　

E列に万一　「af」　や 　「a」　があり、
文字数が多いデータが上側にある場合、「a」はすでに登録済みだというコトになり、
「a」は無視されてしまいます。

その場合はもう一手間かける必要があります。
（E列の文字数の少ない順に並び替えをし、その後マクロを実行する）
といった具合になるかと・・・m(_ _)m
    • good
    • 0
    • 件
通報する

うーん・・・

No.5

  • 回答者： tom04
  • 回答日時：

No.1です。



＞E列に重複データがある場合があります。
＞それはひとつで表示したいです。

D・E列で重複で操作する必要があるのですね。
ただ、補足の例では
「あああ」と「c」の行がありますが、これはどう処理したのでしょうか？

それとも単なる書き間違いでしょうかね？
    • good
    • 0
    • 件
通報する
この回答へのお礼

申し訳ございません。
単なる書き間違いです。
補足5行目の
あああ　cは
あああ　aです。

通報する
お礼日時：2019/05/23 14:50

No.4

  • 回答者： mike_g
  • 回答日時：

[No.2お礼]へのコメント、


》 最初の下記の次式はどれになるでしょうか？
失礼しました、下記間違いと書き漏らしがありました。

「Sheet1 において」の「Sheet1」は「Sheet2」の間違い。
その直下の行の「次式」は
=IFERROR(INDEX(Sheet1!$E:$E,SMALL(IF(Sheet1!$D$3:$D$10=Sheet1!$D3,ROW(Sheet1!D$3:D$10)),COLUMN(Sheet1!A1))),"")
で、この式は必ず配列数式として入力してください。
「配列数式として入力」の方法はご存知ですか？

それから、貴方の「補足日時：2019/05/16 20:16」の「No.1の回答に寄せられた補足コメント」は一切読んでおりません。
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございました。
補足分失礼しました。

通報する
お礼日時：2019/05/23 14:48

No.3

  • 回答者： mike_g
  • 回答日時：

[No.2]誤謬訂正、


》 Sheet3 において、C列は空白行として放置プレー
「空白行」→「空白列」
    • good
    • 0
    • 件
通報する

No.2

  • 回答者： mike_g
  • 回答日時：

添付図参照



Sheet1 において、
次式を入力したセル D3 を右方７列下方７行オートフィル

Sheet3 において、C列は空白行として放置プレー
式 =C3&" "&Sheet2!D3 を入力したセル D3 を右方７列下方７行オートフィル

Sheet1 に戻って、
次式を入力したセル F3 を下方にズズーッとオートフィル
=SUBSTITUTE(TRIM(LOOKUP("黑",Sheet3!3:3))," ",",")
「同じ文字の入ったセルを確認して、別セルの」の回答画像2
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
最初の下記の次式はどれになるでしょうか？
あと、Sheet1ではなくSheet2でしょうか？

Sheet1 において、
次式を入力したセル D3 を右方７列下方７行オートフィル

通報する
お礼日時：2019/05/16 21:03

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

関連するカテゴリからQ&Aを探す

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報