同じ文字列がある場合、行を合わせたい

質問

A列に品番、B列に型式、C列に数量、Ｄ列に品番、E列に型式、F列に数量の
項目があります。
A列～C列とD列～F列をそれぞれ一つの固まりとします。
A列（赤枠）とD列（青枠）の品番がそれぞれ同じ場合、
A列～C列とD列～F列の行を合わせたいのですが、
その場合、エクセル、VBAではどのようなコードを記入すればよろしいでしょうか？
※添付図参照ください
※リストの数は、毎回違います。

エクセルは2010,2007を使用しております。
回答よろしくお願い致します。

回答No.1

keithin · ベストアンサー

趣味に応じて、やり口は様々考えられます。

たとえば、ループしないので比較的高速な方法：
sub macro1()
　range("A2:A" & range("A65536").end(xlup).row).copy range("H2")
　range("D3:D" & range("D65536").end(xlup).row).copy range("H65536").end(xlup).offset(1)
　range("H:H").removeduplicates columns:=1, header:=xlyes
　range("H2:H" & range("H65536").end(xlup).row).sort key1:=range("H2"), order1:=xlascending, header:=xlyes

　range("I2:K" & range("H65536").end(xlup).row).formula = "=VLOOKUP($H2,$A:$C,COLUMN(A2),FALSE)"
　range("L2:N" & range("H65536").end(xlup).row).formula = "=VLOOKUP($H2,$D:$F,COLUMN(A2),FALSE)"
　with range("I2:N" & range("H65536").end(xlup).row)
　　.value = .value
　end with

　on error resume next
　range("I:N").specialcells(xlconstants, xlerrors).clearcontents
　range("I:K").copy range("A1")
　range("L:N").copy range("D1")
　range("H:N").clearcontents
end sub

お礼

回答ありがとうございました。
うまく希望通りになりました。
勉強になりました。

回答No.4

KURUMITO

マクロを実行するといっても複雑で計算に負担がかかります。次のような作業列を使った関数を用いた方法によって処理することもできます。作業列もたくさん使用することになりますが一旦作っておけばデータを簡単に並べることができますね。
シート１のA２セルからF２セルまでにお示しの項目名が有り、３行目から下方にそれぞれのデータが入力されているとします。
そこで作業列ですがG２セルからI２セルまでに品番から数量の項目名を入力します。
G３セルには次の式を入力してI３セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>(COUNTA($A$3:$A$1000)+COUNTA($D$3:$D$1000)),"",IF(MOD(ROW(A1),2)=1,INDEX($A:$C,ROUNDUP(ROW(A1)/2,0)+2,COLUMN(A1)),INDEX($D:$F,ROUNDUP(ROW(A1)/2,0)+2,COLUMN(A1))))

上の操作はA列からF列までのデータを単に並び替えたものです。
J３セルには次の式を入力して下方にドラッグコピーします。

=IF(G3="","",CODE(G3)+CODE(MID(G3,2,1))/100)

上の操作は品番をアルファベット順に並べるために必要なデータを表示しています。
K３セルには次の式を入力して下方にドラッグコピーします。

=IF(J3="","",RANK(J3,J:J,1))

L３セルには次の式を入力して下方にドラッグコピーします。

=IF(K3="","",IF(MOD(ROW(A1),2)=1,1000+K3,2000+K3))

M３セルからR３セルにはA３セルからF３セルまでの項目名をコピーして貼り付けます。
その後にM４セルには次の式を入力してR４セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IFERROR(IF(COLUMN(A1)<=3,INDEX($G:$I,MATCH(1000+ROW(A1),$L:$L,0),COLUMN(A1)),INDEX($G:$I,MATCH(2000+ROW(A1),$L:$L,0),COLUMN(A1)-3)),"")

S３セルには次の式を入力して下方にドラッグコピーします。

=IF(OR(M3<>"",P3<>""),MAX(S$2:S2)+1,"")

T３セルからY３セルにはA３セルからF３セルまでの項目名をコピーして貼り付けます。
T４セルには次の式を入力してY４セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX($S:$S),"",INDEX($M:$R,MATCH(ROW(A1),$S:$S,0),COLUMN(A1)))

このT列からY列までの表がお求めの表となります。

T列からY列までを選択して「コピー」し別のシートのA１セルを選択してから「形式を選択して貼り付け」で「値」にチェックをして貼り付ければマクロでの操作と同じことになります。
つまりシート１でのA列からF列までのデータが変わっても前のデータが表示されたままとなりますね。
別のシートでもシート１でのデータの入力などが行われた場合に即座に対応した表を表示させるのでしたら別のシートのA１セルに次の式を入力して右方向にドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(Sheet1!T1="","",Sheet1!T1)

マクロの場合には一々操作を行わなければ前のデータ表示のままですが、関数を使って表示している場合にはシート１でのデータの変化が即座に反映されますね。

お礼

そんな方法もあるのですね。
勉強になります。
ありがとうございました。

回答No.3

tom04

No.2です！
たびたびごめんなさい。

前回のコードでは最終行の取得方法に間違いがありました。
前回のコードは無視して↓のコードにしてみてください。

Sub test2()
Dim i As Long
Dim k As Long
Dim cnt As Long

Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(i, 3)).Sort key1:=Cells(2, 1), order1:=xlAscending, Header:=xlYes
k = Cells(Rows.Count, 4).End(xlUp).Row
Range(Cells(2, 4), Cells(k, 4)).Sort key1:=Cells(2, 4), order1:=xlAscending, Header:=xlYes

On Error Resume Next
cnt = 3
Do Until cnt = Cells(Rows.Count, 4).End(xlUp).Row
If WorksheetFunction.CountIf(Columns(1), Cells(cnt, 4)) Then
k = WorksheetFunction.Match(Cells(cnt, 4), Columns(1), False)
If k > cnt Then
Range(Cells(cnt, 4), Cells(Cells(Rows.Count, 4).End(xlUp).Row, 6)).Cut Cells(k, 4)
End If
End If
cnt = cnt + 1
Loop

cnt = 3
Do Until cnt = Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Columns(4), Cells(cnt, 1)) Then
i = WorksheetFunction.Match(Cells(cnt, 1), Columns(4), False)
If i > cnt Then
Range(Cells(cnt, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).Cut Cells(i, 1)
End If
End If
cnt = cnt + 1
Loop
Application.ScreenUpdating = True
End Sub

※　しっかり検証していませんので、ご希望の表示にならなかったらごめんなさいね。m(_ _)m

お礼

回答ありがとうございました。
勉強になりました。

回答No.2

tom04

こんばんは！
一例です。

画像ではA列・D列が昇順になっていないようですので、勝手に並び替えをしています。

Sub test()
Dim i As Long
Dim k As Long
Dim m As Long
Dim n As Long
Dim aRow As Long
Dim dRow As Long

Application.ScreenUpdating = False
aRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(aRow, 3)).Sort key1:=Cells(2, 1), order1:=xlAscending, header:=xlYes
dRow = Cells(Rows.Count, 4).End(xlUp).Row
Range(Cells(2, 4), Cells(dRow, 4)).Sort key1:=Cells(2, 4), order1:=xlAscending, header:=xlYes

On Error Resume Next
For k = 2 To dRow
If WorksheetFunction.CountIf(Columns(1), Cells(k, 4)) Then
m = WorksheetFunction.Match(Cells(k, 4), Columns(1), False)
If m > k Then
Range(Cells(k, 4), Cells(Cells(Rows.Count, 4).End(xlUp).Row, 6)).Cut Cells(m, 4)
End If
End If
Next k

aRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To aRow
If WorksheetFunction.CountIf(Columns(4), Cells(aRow, 1)) Then
n = WorksheetFunction.Match(Cells(i, 1), Columns(4), False)
If n > i Then
Range(Cells(i, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).Cut Cells(n, 1)
End If
End If
Next i
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m