はじめての親子ハイキングに挑戦!! >>

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

例として下記データ(文字は例として挙げただけなので、文字数とかばらばらです)があります。
  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.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

以下でどうなりますか




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.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

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



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

こんにちは



すでに回答は出ているようですが、別法での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.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.1です。



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

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

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

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

お礼日時:2019/05/23 14:50

[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.2]誤謬訂正、


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

添付図参照



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

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

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

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

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

お礼日時:2019/05/16 21:03

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

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング