シート名：A
シート名：A A列 B列 C列 D列 場所名 果物名 色 評価 東京 りんご1 青 1 東京 りんご2 青 1 大阪 りんご3 赤 2 大阪 りんご4 赤 2 名古屋 りんご5 黄 3 シート名：B A列 B列 C列 東京 りんご12 青 1 大阪 りんご34 赤 2 名古屋 りんご5 黄 3 上記の表にて、シート名AでA列+C列が同じ場合に シート名BのA列(最終行)に 場所名+果物名+数字を入力及びシート名AのC、D列の値を シート名Bの、B列+C列に入力する ※果物名は同じの為、数字のみ後ろに追加していく ※シート名AのC、D列は各セルで同じ値です。 マクロはどのようになるのでしょうか？
Visual Basic・90閲覧
ベストアンサー
Sub test() Dim dic As Object Dim r As Long Dim dkey As Variant Dim vals As Variant Dim i As Integer Dim buf As String Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") With Worksheets("A") For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row dkey = .Cells(r, 1).Value & .Cells(r, 3).Value If dic.Exists(dkey) = False Then vals = Array(.Cells(r, 3).Value, .Cells(r, 2).Value, .Cells(r, 3).Value, .Cells(r, 4).Value) dic.Add dkey, vals Else vals = dic.Item(dkey) buf = "" For i = 1 To Len(.Cells(r, 2).Value) If Mid(.Cells(r, 2).Value, i, 1) Like "[0-9]" Then buf = buf & Mid(.Cells(r, 2).Value, i, 1) End If Next i vals(1) = vals(1) & buf dic.Item(dkey) = vals End If Next r End With With Worksheets("B") If .Cells(1, 1).Value = "" Then r = 0 Else r = .Cells(Rows.Count, 1).End(xlUp).Row End If For Each dkey In dic.Keys vals = dic.Item(dkey) r = r + 1 .Cells(r, 1).Value = Replace(dkey, vals(0), "") & vals(1) .Cells(r, 2).Value = vals(2) .Cells(r, 3).Value = vals(3) Next dkey End With Set dic = Nothing Application.ScreenUpdating = True End Sub
質問者からのお礼コメント
助かりました。 ありがとうございました。
お礼日時：5/22 17:26
