Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
条件に一致した値を結合して1行飛ばしで貼り付ける
投稿日時: 20/06/10 11:35:47
投稿者: VBA学習中

皆様、お世話になります。よろしくお願いします。
 
A列に日付がありB列に内容が記載されています
D列の日付の条件をA列から検索して、A列で条件に一致したB列の値を全て結合
結合した値をE列に張り付けたいです。
ExcelVBAで実行したいのですがうまくいきません。
 
 A B C D E
日付    内容        日付    結合            
1    ABC        1    ABC DFE GHI            
2    JKL                        
3    STU        2    JKL MNO PQR            
4    A123                        
5    B123        3    STU VWX YZ            
6    C123                        
1    DFE        4    A123 A456 A789            
2    MNO                        
3    VWX        5    B123 B456 B789            
4    A456                        
5    B456        6    C123 C456 C789            
6    C456                        
1    GHI                        
2    PQR                        
3    YZ                        
4    A789                        
5    B789                        
6    C789                        
                            
よろしくお願いいたします。                            

回答
投稿日時: 20/06/10 20:18:17
投稿者: simple

こんにちは。
現時点の中途でもよいので、コードを示してもらうとよいと思うのですが、
疑似的なコードで考え方を示してみます。
(色々なやりかたがありますが、一例です)
 
D列には日付が既に入っているものとします。
 

For k = 2 TO A列の最終行
    Cells(k,"A")をApplication.Matchで D列の何行目かにあるか探します。
    仮にこれをp行とします。
    Cells(p,"D") に Cells(k,"A")の値を文字列連結する。(間にスペースを挟む)
Next

概略こういう考え方でトライしてみてはどうでしょうか。

回答
投稿日時: 20/06/11 19:08:35
投稿者: simple

難しかったですか。以下を参考にしてみてください。
 
こちらは、D列に予め日付がセットされている前提のもの。
(前に"考え方"を示しましたが、それに沿ったものです。
  なお、文字列の最後にスペースが残るので、それもカットするようにしています。)
 

Sub test1()
    Dim k   As Long
    Dim day As Long
    Dim p   As Long
    Dim s   As String
    
    'A列の文字列を、E列に、連結しながら書き込む
    For k = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        day = Cells(k, "A").Value
        p = Application.Match(day, Columns("D"), 0)
        If Not IsError(p) Then
            Cells(p, "E") = Cells(p, "E") & Cells(k, "B") & " "
        End If
    Next
    
    '文字列の最後に残っているスペースを除去
    For k = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        s = Cells(k, "E")
        If s <> "" Then
            Cells(k, "E") = Left(s, Len(s) - 1)
        End If
    Next
End Sub

こちらの掲示板は、規約により、コードの作成依頼は禁止されています。
どこからが作成依頼で、どこまでが質問なのか境界は判然としませんが、
少なくとも、途中段階のコードを示して、この部分がわからない、
ここから先がわからない、と言う質問をしてもらうと、
お互いに有益なんじゃないかと思います。

回答
投稿日時: 20/06/11 19:34:55
投稿者: simple

以下は、D列に予め日付が書かれてはいないケースにも対応できるもの。
Dictionaryというデータ構造を使っていますので、少し難しいかもしれません。
今後の参考と言うことで書いておきます。
 

Sub test2()
    Dim dic  As Object
    Dim key  As Variant
    Dim k    As Long
    Dim day  As Long
    Dim p    As Long
    
    Set dic = CreateObject("Scripting.Dictionary")

    For k = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        day = Cells(k, "A").Value
        dic(CStr(day)) = dic(CStr(day)) & Cells(k, "B").Value & " "
    Next
    
    p = 2
    For Each key In dic
        Cells(p, "D").Value = CLng(key)
        Cells(p, "E").Value = Left(dic(key), Len(dic(key)) - 1)
        p = p + 2
    Next
End Sub

投稿日時: 20/06/12 10:26:15
投稿者: VBA学習中

@simple 様
ありがとうございます!
Unionを使用して一括で貼り付けようとやっていましたがsimple 様が記述していただいたコードで
セルの値に追加していく方法もあるのだと改めて感心しました。
D列の数値を日付にする必要があったのですが難なく希望通りのコードでした。
次回質問するときは途中までのコードも載せるようにしたいと思います。