EXCLEのマクロ 2つのシートを統合する方法

質問

下記のことを行いたいのです。
教えていただけないでしょうか。

下記2つのシートをA列をキーにして
sheet1のあ、b、c列のデータに sheet2のc、d列を
統合して、sheet1のdれつ e列に統合して5列のデータを作りたい

a列とb列のデータは基本同じですが、スペースが入っていたり
違う場合もある。B列はsheet1のデータを採用 sheet2は不要

・sheet1

a列 b列 C列

123 ああ 123456
456 いい 125456
789 うう 12344556
1234 ええ 12345678
4567 おお 123456456
8945 かか 1234567844

-------------------
・sheet2

a列 B列 C列 D列

123 ああ 03-5212-0000 東京都○
456 いい 06-5212-0000 大阪府○
789 うう 044-5212-0000 神奈川県○
1234 ええ 045-512-0000 横浜市○
4567 おお 043-212-0000 埼玉県○
8945 かか 03-5212-0000 東京都○

回答No.5

ka_na_de · ベストアンサー

＃２です。

再修正します。
前回の回答でも動きますが、
A列は数値ということでしたので、
空白のみ削除するように修正しました。

Sub Test03()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myLastRow1 As Long
　　Dim myLastRow2 As Long
　　Dim i As Long
　　Dim myRng1 As Range
　　Dim myRng2 As Range
　　Dim myKey As String

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")

　　myLastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row

　　Set myRng1 = Ws1.Range("A2:A" & myLastRow1)
　　Set myRng2 = Ws2.Range("A2:A" & myLastRow2)

　　Call KuuhakuCnv(myRng1)
　　Call KuuhakuCnv(myRng2)

　　With Ws2
　　　　For i = 2 To myLastRow1
　　　　　　myKey = Ws1.Cells(i, "A").Value
　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=myKey
　　　　　　If .Range("A1:A" & myLastRow2).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
　　　　　　　　.Range("C2:D" & myLastRow2).SpecialCells(xlCellTypeVisible).Resize(1).Copy _
　　　　　　　　　　Destination:=Ws1.Cells(i, "D")
　　　　　　End If
　　　　Next i
　　　　.AutoFilterMode = False
　　End With

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRng1 = Nothing
　　Set myRng2 = Nothing
End Sub

Sub KuuhakuCnv(argRng As Range)
　　Dim r As Range
　　For Each r In argRng
　　　　r.Value = Trim(r.Value) '前後の空白を除去する
　　　　r.Value = Replace(r.Value, " ", "") '半角空白を除去（置換）
　　　　r.Value = Replace(r.Value, "　", "") '全角空白を除去（置換）
　　Next r
End Sub

お礼

大変ありがとうございました。
本当に感謝です。

ばっちりうまくいきました。

ここまで対応していただいたことにおいて、
御礼申し上げます。

回答No.4

ka_na_de

＃２です。

修正しました。

オートフィルターで絞り込まれた件数が１件以上の場合に
最上位のデータをコピー＆ペーストします。

Sub Test02()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myLastRow1 As Long
　　Dim myLastRow2 As Long
　　Dim i As Long
　　Dim myRng1 As Range
　　Dim myRng2 As Range
　　Dim myKey As String

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")

　　myLastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row

　　Set myRng1 = Ws1.Range("A2:A" & myLastRow1)
　　Set myRng2 = Ws2.Range("A2:A" & myLastRow2)

　　Call ZenkakuCnv(myRng1)
　　Call ZenkakuCnv(myRng2)
　　Call KuuhakuCnv(myRng1)
　　Call KuuhakuCnv(myRng2)

　　With Ws2
　　　　For i = 2 To myLastRow1
　　　　　　myKey = Ws1.Cells(i, "A").Value
　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=myKey
　　　　　　If .Range("A1:A" & myLastRow2).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
　　　　　　　　.Range("C2:D" & myLastRow2).SpecialCells(xlCellTypeVisible).Resize(1).Copy _
　　　　　　　　　　Destination:=Ws1.Cells(i, "D")
　　　　　　End If
　　　　Next i
　　　　.AutoFilterMode = False
　　End With

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRng1 = Nothing
　　Set myRng2 = Nothing
End Sub

Sub ZenkakuCnv(argRng As Range)
　　Dim r As Range
　　For Each r In argRng
　　　　r.Value = StrConv(r.Value, vbWide) '半角を全角に変換
　　Next r
End Sub

Sub KuuhakuCnv(argRng As Range)
　　Dim r As Range
　　For Each r In argRng
　　　　r.Value = Trim(r.Value) '前後の空白を除去する
　　　　r.Value = Replace(r.Value, " ", "") '半角空白を除去（置換）
　　　　r.Value = Replace(r.Value, "　", "") '全角空白を除去（置換）
　　Next r
End Sub

回答No.3

keithin

統合キーとして１列しか採用しないなら，（わざわざマクロにしなくても）簡単な関数だけで何の問題もなく出来ます。

sub macro1()
with worksheets("Sheet1").range("D2:E" & worksheets("Sheet1").range("A65536").end(xlup).row)
.formular1c1 = "=IF(COUNTIF(Sheet2!C1,RC1),VLOOKUP(RC1,Sheet2!C1:C4,COLUMN(RC[-1]),FALSE)&"""","""")"
.value = .value
end with
end sub

お礼

アドバイスいただきありがとうございます。
私の説明も悪く2度も回答いただき深謝しております。

今回は他の回答のソースにてうまくいくことが出来ました。

ありがとうございました。

回答No.2

ka_na_de

こんばんは。

Sheet1、Sheet2ともに１行目に見出し行がある前提で
作りました。

A列B列のデータ中の空白を削除し、
半角カナは全角カナに変換したうえで統合します。
Sheet2にA列の値が同じデータが複数存在した場合は
最上位のデータを採用します。

Sub Test01()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myLastRow1 As Long
　　Dim myLastRow2 As Long
　　Dim i As Long
　　Dim myRng1 As Range
　　Dim myRng2 As Range
　　Dim myKey As String

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")

　　myLastRow1 = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
　　myLastRow2 = Ws2.Cells(Ws2.Rows.Count, "A").End(xlUp).Row

　　Set myRng1 = Ws1.Range("A2:B" & myLastRow1)
　　Set myRng2 = Ws2.Range("A2:B" & myLastRow2)

　　Call ZenkakuCnv(myRng1)
　　Call ZenkakuCnv(myRng2)
　　Call KuuhakuCnv(myRng1)
　　Call KuuhakuCnv(myRng2)

　　With Ws2
　　　　For i = 2 To myLastRow1
　　　　　　myKey = Ws1.Cells(i, "A").Value
　　　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　　　.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=myKey
　　　　　　.Range("C2:D" & myLastRow2).SpecialCells(xlCellTypeVisible).Resize(1).Copy _
　　　　　　　　Destination:=Ws1.Cells(i, "D")
　　　　Next i
　　　　.AutoFilterMode = False
　　End With

　　Set myRng1 = Nothing
　　Set myRng2 = Nothing
End Sub

Sub ZenkakuCnv(argRng As Range)
　　Dim r As Range
　　For Each r In argRng
　　　　r.Value = StrConv(r.Value, vbWide) '半角カナを全角カナに変換
　　Next r
End Sub

Sub KuuhakuCnv(argRng As Range)
　　Dim r As Range
　　For Each r In argRng
　　　　r.Value = Trim(r.Value) '前後の空白を除去する
　　　　r.Value = Replace(r.Value, " ", "") '半角空白を除去（置換）
　　　　r.Value = Replace(r.Value, "　", "") '全角空白を除去（置換）
　　Next r
End Sub

お礼

追伸：スイマセン
先ほどの補足ですが、A列のキーにおいても一致しないデータも一部あります。
そのデータは無視して欲しいのです。

また、1行目には項目データはあります。

補足

ご返事が遅くなり申し訳ございません。
私の説明が間違っておりました。
昨晩自分なりに改造してみようと行ったのですがうまくいきませんした。

訂正箇所
各sheetのB列ですが、データは違う場合もあります。
したがって、A列 数値データのみキーにして
sheet2のCretu （電話番号）D列（住所データ）をSheetaにコピーして
統合したいのです。

再度ご相談させていただけますでしょうか。

回答No.1

keithin

シート１のD1に
=INDEX(Sheet2!C:C,IF(COUNT(1/(TRIM(Sheet2!$A$1:$A$10)&TRIM(Sheet2!$B$1:$B$10)=TRIM($A1)&TRIM($B1))),MATCH(TRIM($A1)&TRIM($B1),TRIM(Sheet2!$A$1:$A$10)&TRIM(Sheet2!$B$1:$B$10),0),9999))&""
と入れてコントロールキーとシフトキーを押しながらEnter，下に右にコピーします。

#多分簡単なやり方より難しいほど嬉しいですね？

補足

ご返事遅くなり恐縮です。
他の方の回答にも補足したのですが、私の説明が間違っておりました

B列は必ずしも一致しておりませんでした。
A列の数値データのみをキーにして、sheet2のC列 D列をaheet1の方に
追加したいのです。