Excel (VBA)

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

 
(Windows 10全般 : Excel 2016)
VBAで値を抽出、別シートへの転記
投稿日時: 21/08/23 17:11:57
投稿者: むぎまき

シート1のC列をkeyとして、シート2のB列から探して一致した場合に、
シート1のU列のデータをシート2のAC列に転記したいです。
(シート2のB列で値の重複はありません)
ただ、抽出した値が複数ある場合に以下のように転記をしたいのですが、
どのようにコードを記載したらよいかわかりません。
 
【シート1】※転記元   【シート2】※転記先
C列    U列       B列    AC列
Key1   東京      key1  東京/千葉
Key1   千葉      key2  東京 ←空欄は転記しない
Key2   東京      key3  埼玉
Key2   空欄
Key3   埼玉
 
下のコードの
【Cells(i, n + 29) = myStr(n) '出力】の部分を修正かと思うのですが、
どのように修正すればよいのかお教え頂けますでしょうか。
 
 
sub 転記
 
    Dim Keyval As String
    Dim Itemval As String
    Dim i As Long
    Dim n As Long
    Dim myStr As Variant
    Dim myDic As Object
 
  Set myDic = CreateObject("Scripting.Dictionary")
    Last_Row01 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
 
    For i = 2 To Last_Row01
        Keyval = Sheets(1).Cells(i, 3) 'Keyを格納
        Itemval = Sheets(1).Cells(i, 21) 'Itemを格納
 
        If Not myDic.Exists(Keyval) Then
            myDic.Add Keyval, Itemval
         Else
            myDic(Keyval) = myDic(Keyval) & "/" & Itemval
        End If
    Next i
 
    LastRow02 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow02
        Keyval = Sheets(2).Cells(i, 2)
        myStr = Split(myDic(Keyval), "/")
        For n = 0 To UBound(myStr)
            Cells(i, n + 29) = myStr(n) '出力
        Next n
    Next i
 
    Set myDic = Nothing
 
End Sub

回答
投稿日時: 21/08/23 17:40:57
投稿者: コレ

 こんにちは
 
 不要な部分を削除しただけですが、例題の結果にはなるかと思います。
 列の数字を変更してしまいましたので、また直してください。
 
Sub 転記()
    Dim Last_Row01 As Long
    Dim Last_Row02 As Long
    Dim Keyval As String
    Dim Itemval As String
    Dim i As Long
    Dim n As Long
    Dim myStr As Variant
    Dim myDic As Object
  
    Set myDic = CreateObject("Scripting.Dictionary")
    Last_Row01 = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
  
    For i = 2 To Last_Row01
        Keyval = Sheets(1).Cells(i, 3).Value 'Keyを格納
        Itemval = Sheets(1).Cells(i, 4).Value 'Itemを格納
  
        If Not myDic.Exists(Keyval) Then
            myDic.Add Keyval, Itemval
         ElseIf Itemval <> "" Then
            myDic(Keyval) = myDic(Keyval) & "/" & Itemval
        End If
    Next i
  
    Last_Row02 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row
     
    For i = 2 To Last_Row02
        Keyval = Sheets(2).Cells(i, 2).Value
        myStr = myDic(Keyval)
        Sheet2.Cells(i, 3) = myStr '出力
    Next i
  
    Set myDic = Nothing
  
End Sub

投稿日時: 21/08/23 17:56:05
投稿者: むぎまき

コレ様
教えていただきありがとうございます。
大変恐縮ですが、key2のような場合、"/東京"と頭に/が入った状態となってしまうのですが、
こちらを"東京"のみとするにはどのようにすればよろしいかご教授いただけますでしょうか。

回答
投稿日時: 21/08/23 18:03:00
投稿者: コレ

 こんばんは
 
 実データで試すとそうなるってことですか。
 
        If Not myDic.Exists(Keyval) Then
            myDic.Add Keyval, Itemval
         ElseIf Itemval <> "" Then
            myDic(Keyval) = myDic(Keyval) & "/" & Itemval
        End If
 
 上記コードのmyDic.Add Keyval, Itemvalのところを
Itemvalが空欄ならmyDicに追加しないようにすればどうですか?
 
 if itemval<>"" then
    myDic.Add Keyval, Itemval
  end if
 
 と、IF分を追加してどうですか?

回答
投稿日時: 21/08/23 20:06:36
投稿者: コレ

 こんばんは
 後で考えたら下記ので良かったと思い訂正します。
 
Sub 転記()
    Dim Last_Row01 As Long
    Dim Last_Row02 As Long
    Dim Keyval As String
    Dim Itemval As String
    Dim i As Long
    Dim n As Long
    Dim myStr As Variant
    Dim myDic As Object
   
    Set myDic = CreateObject("Scripting.Dictionary")
    Last_Row01 = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
   
    For i = 2 To Last_Row01
        Keyval = Sheets(1).Cells(i, 3).Value 'Keyを格納
        Itemval = Sheets(1).Cells(i, 4).Value 'Itemを格納
        If Itemval <> "" Then
            If Not myDic.Exists(Keyval) Then
                myDic.Add Keyval, Itemval
             Else
                myDic(Keyval) = myDic(Keyval) & "/" & Itemval
            End If
        End If
    Next i
   
    Last_Row02 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row
      
    For i = 2 To Last_Row02
        Keyval = Sheets(2).Cells(i, 2).Value
        myStr = myDic(Keyval)
        Sheet2.Cells(i, 3) = myStr '出力
    Next i
   
    Set myDic = Nothing
   
End Sub

回答
投稿日時: 21/08/24 21:21:49
投稿者: WinArrow
投稿者のウェブサイトに移動

横から失礼します。
  

引用:
Last_Row02 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row
         
    For i = 2 To Last_Row02
        Keyval = Sheets(2).Cells(i, 2).Value
        myStr = myDic(Keyval)
        Sheet2.Cells(i, 3) = myStr '出力
    Next i
 

は、Sheets(2)とSheet2の両方を使っている、間違いではないが
  
   With Sheets(2)
        Last_Row02 = .Range("B" & Rows.Count).End(xlUp).Row
      
        For i = 2 To Last_Row02
            Keyval = .Cells(i, "B").Value
            myStr = myDic(Keyval)
            .Cells(i, [color=red]"AC"[/color]) = myStr '出力
        Next i
    End With

の方がすっきりすると思います。
それと、代入セルは、AC列に修正してあります。

投稿日時: 21/08/25 13:25:22
投稿者: むぎまき

コレ様
WinArrow様
ありがとうございます。
お二方にお教えいただいたコードで希望通りの処理が出来ました。
本当に助かりました。
自分でコードの意味を読み解けるように勉強します。