回答受付が終了しました

エクセルVBAについて 当方初心者につきどなたかお知恵をお貸し下さい。

エクセルVBAについて 当方初心者につきどなたかお知恵をお貸し下さい。 添付の図のようにA列に日付が、B列に顧客名が、C列に商品名が入っております(この書式はシステム上変えることはできません)。この並びを図の右側のように同じ日付で同じ名前なら同一列に商品が並ぶようなコードをお教え頂きたいです。 商品は最大で10個までしかありません。 お詳しい方、お知恵をお貸し下さい。お願い致します。

画像

Excel67閲覧xmlns="http://www.w3.org/2000/svg">100

1人が共感しています

回答(4件)

0

重複の削除を使う方法、 Sub test() Dim i As Long, flg As Long, mystr As String, D As Variant Sheets("Sheet1").Copy after:=Sheets("Sheet1") Range("A1").CurrentRegion.Sort _ key1:=Range("A2"), order1:=xlAscending, _ key2:=Range("B2"), order2:=xlAscending, _ Header:=xlYes D = Range("A1").CurrentRegion.Value For i = 2 To UBound(D) - 1 If D(i, 1) = D(i + 1, 1) And D(i, 2) = D(i + 1, 2) Then If flg = 0 Then D(i + 1, 3) = D(i, 3) & "," & D(i + 1, 3) flg = i Else D(i + 1, 3) = D(i, 3) & "," & D(i + 1, 3) End If End If If flg <> 0 And D(i, 2) <> D(i + 1, 2) Then D(flg, 3) = D(i, 3) flg = 0 End If Next Application.ScreenUpdating = False Range("A1").Resize(UBound(D), 3) = D Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes Range("C2", Cells(Rows.Count, 3).End(xlUp)).TextToColumns Range("C2"), xlDelimited, comma:=True Application.DisplayAlerts = False Range("C1").Resize(, 10).Merge Application.DisplayAlerts = True Columns("A:L").AutoFit End Sub

0

マクロより 関数の方が 早い気がします。 添付参照 D2に =IF(COUNTIFS(A$2:A2,A2,B$2:B2,B2)=1,MAX(D$1:D1)+1,"") 以下オートフィル E2に =A2&"-"&B2&"-"&COUNTIFS(A$2:A2,A2,B$2:B2,B2) 以下オートフィル G2に =IFERROR(INDEX(A:A,MATCH(ROW(A1),$D:$D,0)),"") E2に コピー G2:E2を 下にオートフィル I2に =IFERROR(INDEX($C:$C,MATCH($G2&"-"&$H2&"-"&COLUMN(A1),$E:$E,0)),"") L列迄オートフィル I2:L2を 下にオートフィル

画像
0

一例です。 不明な部分は勝手な想像で組みました。 適宜変更してください。 コードの利用・改変は自由にしていただいて構いませんが、 他の掲示板やスレにコピペはお控えください。 他で利用する場合は必ずこのスレのリンクにてお願いします。 Sub sample1() Dim mySheet As Worksheet Dim myDIC As Object Dim myKey As Variant Dim myDAT() As String Dim myR As Long, myC As Long Set myDIC = CreateObject("Scripting.Dictionary") Set mySheet = ActiveSheet With mySheet     For myR = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row         myKey = .Cells(myR, 1).Value & "," & .Cells(myR, 2).Value         If myDIC.Exists(myKey) Then             myDAT = myDIC(myKey)             ReDim Preserve myDAT(1 To UBound(myDAT) + 1)         Else             ReDim myDAT(1 To 1)         End If         myDAT(UBound(myDAT)) = .Cells(myR, 3).Value         myDIC(myKey) = myDAT     Next myR End With Set mySheet = Application.Workbooks.Add(xlWBATWorksheet).Sheets(1) With mySheet     myR = 0     For Each myKey In myDIC.Keys         myDAT = myDIC(myKey)         If myC < UBound(myDAT) Then myC = UBound(myDAT)         myR = myR + 1         .Cells(myR, 1).Resize(1, 2).Value = Split(myKey, ",")         .Cells(myR, 3).Resize(1, UBound(myDAT)).Value = myDAT     Next myKey     .Cells(1, 3).Resize(1, myC).FillRight End With Set myDIC = Nothing Set mySheet = Nothing End Sub

0

>添付の図のようにA列に日付が、B列に顧客名が、C列 >に商品名が入っております(この書式はシステム上変えることはできません)。 だったら、VBAで並び替えることは可能なのでしょうか?