こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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 東京都○

投稿日時 - 2010-03-31 14:26:34

QNo.5792424

すぐに回答ほしいです

質問者が選んだベストアンサー

#2です。

再修正します。
前回の回答でも動きますが、
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

投稿日時 - 2010-04-01 12:54:14

お礼

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

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

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

投稿日時 - 2010-04-01 14:17:05

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.4

#2です。

修正しました。

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

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

投稿日時 - 2010-04-01 12:46:49

ANo.3

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

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

投稿日時 - 2010-04-01 10:09:42

お礼

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

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

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

投稿日時 - 2010-04-01 14:18:31

ANo.2

こんばんは。

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

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

投稿日時 - 2010-03-31 21:33:19

補足

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

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

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

投稿日時 - 2010-04-01 09:20:03

お礼

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

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

投稿日時 - 2010-04-01 09:28:59

ANo.1

シート1の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,下に右にコピーします。



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

投稿日時 - 2010-03-31 20:00:41

補足

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

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

投稿日時 - 2010-04-01 09:23:36

あなたにオススメの質問