2つのexcelのシートに載っている情報を、IDが同じものについて横付けさせるマクロを作りたいのですが、どうすればいいでしょうか？
たとえばファイルAには年齢と性別、ファイルBには住所と電話番号が書いてあって
それぞれIDが振られています。
ファイルA
ID 年齢 性別
1 35 男
2 40 女
3 20 女
ファイルB
ID 住所 電話番号
1 A市 5240-####
2 B市 4020-####
4 C市 3540-####
作りたいファイル
ID 年齢 性別 住所 電話番号
1 35 男 A市 5240-####
2 40 女 B市 4020-####
3 20 女
4 C市 3540-####
実際にはカラムの数は5-15ほどあります。
いつもはvlookupなどを使ってちょこまかやっているのですが、あまりに頻度が多いので便利にしたいと思うのです。
簡単なマクロは作っていますが、VBAは超初心者です。
マクロではなくても、使えそうなフリーウエアなどでもあれば教えてください。
現在MacユーザーなのでAccessは使えません。
よろしくお願いします。
たとえばファイルAには年齢と性別、ファイルBには住所と電話番号が書いてあって
それぞれIDが振られています。
ファイルA
ID 年齢 性別
1 35 男
2 40 女
3 20 女
ファイルB
ID 住所 電話番号
1 A市 5240-####
2 B市 4020-####
4 C市 3540-####
作りたいファイル
ID 年齢 性別 住所 電話番号
1 35 男 A市 5240-####
2 40 女 B市 4020-####
3 20 女
4 C市 3540-####
実際にはカラムの数は5-15ほどあります。
いつもはvlookupなどを使ってちょこまかやっているのですが、あまりに頻度が多いので便利にしたいと思うのです。
簡単なマクロは作っていますが、VBAは超初心者です。
マクロではなくても、使えそうなフリーウエアなどでもあれば教えてください。
現在MacユーザーなのでAccessは使えません。
よろしくお願いします。
|
|
|
|
コメント(12)
kushimaさん
ありがとうございます。
> いつもはvlookupなどを使ってちょこまかやっているのですが、あまりに頻度が多
> いので便利にしたいと思うのです。
と書きましたように、vlookupはいつも使っています。が、もう一段便利に、ぽちっとボタンおして終わり、くらいにしたいなとおもっています。
2ファイルのカラム数と行数を取得して、vlookupを貼り付けるマクロというので十分かもしれないのですが、どちらかだけに含まれている行をどう扱うのが（方法はいろいろあるけれど）一番効率的かと考えています。
Columns関数は参考になりました。早速使います。ありがとうございました。
他にもtipsでもsuggestionいただければ幸いです。よろしくおねがいします。
ありがとうございます。
> いつもはvlookupなどを使ってちょこまかやっているのですが、あまりに頻度が多
> いので便利にしたいと思うのです。
と書きましたように、vlookupはいつも使っています。が、もう一段便利に、ぽちっとボタンおして終わり、くらいにしたいなとおもっています。
2ファイルのカラム数と行数を取得して、vlookupを貼り付けるマクロというので十分かもしれないのですが、どちらかだけに含まれている行をどう扱うのが（方法はいろいろあるけれど）一番効率的かと考えています。
Columns関数は参考になりました。早速使います。ありがとうございました。
他にもtipsでもsuggestionいただければ幸いです。よろしくおねがいします。
fileA.xlsとfileB.xlsを同じフォルダに置き、fileA.xlsに以下のコードをペーストして実行。
簡単なテストしかしてないのでつかえるかどうかもわかりませんが…(^^;
ID列が重複しますが、一応確認できるようそのままにしてあります。
確認後に削除でも手間かかりませんので〜。
Option Explicit
Sub Macro1()
Const FILEB_BOOKS As String = "fileB.xls"
Const FILEB_SHEET As String = "Sheet1"
Dim strPath As String
Dim objB As Workbook
Dim buf As Variant
Dim n As Long
Dim num As Long
Dim i As Long
Dim Target As Variant
Dim j As Long
On Error Resume Next
Set objB = Workbooks(FILEB_BOOKS)
On Error GoTo 0
If objB Is Nothing Then
strPath = ThisWorkbook.Path & "\" & FILEB_BOOKS
On Error Resume Next
Workbooks.Open strPath
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox FILEB_BOOKS & "が存在しません。", vbCritical
Exit Sub
Else
Set objB = Workbooks(FILEB_BOOKS)
End If
End If
With objB
With .Sheets(FILEB_SHEET).Range("A1")
buf = .CurrentRegion
n = .CurrentRegion.Columns.Count
End With
.Saved = True
.Close
End With
With ThisWorkbook.Sheets("Sheet1")
num = .Range("A1").CurrentRegion.Columns.Count - 1
For i = LBound(buf) To UBound(buf)
Set Target = .Range("A1:A65536").Find(What:=buf(i, 1) _
, LookAt:=xlPart, MatchCase:=False, MatchByte:=False)
If Not Target Is Nothing Then
For j = LBound(buf) To n
Target.Offset(, num + j).Value = buf(i, j)
Next j
End If
Next i
End With
Set objB = Nothing
Set Target = Nothing
End Sub
簡単なテストしかしてないのでつかえるかどうかもわかりませんが…(^^;
ID列が重複しますが、一応確認できるようそのままにしてあります。
確認後に削除でも手間かかりませんので〜。
Option Explicit
Sub Macro1()
Const FILEB_BOOKS As String = "fileB.xls"
Const FILEB_SHEET As String = "Sheet1"
Dim strPath As String
Dim objB As Workbook
Dim buf As Variant
Dim n As Long
Dim num As Long
Dim i As Long
Dim Target As Variant
Dim j As Long
On Error Resume Next
Set objB = Workbooks(FILEB_BOOKS)
On Error GoTo 0
If objB Is Nothing Then
strPath = ThisWorkbook.Path & "\" & FILEB_BOOKS
On Error Resume Next
Workbooks.Open strPath
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox FILEB_BOOKS & "が存在しません。", vbCritical
Exit Sub
Else
Set objB = Workbooks(FILEB_BOOKS)
End If
End If
With objB
With .Sheets(FILEB_SHEET).Range("A1")
buf = .CurrentRegion
n = .CurrentRegion.Columns.Count
End With
.Saved = True
.Close
End With
With ThisWorkbook.Sheets("Sheet1")
num = .Range("A1").CurrentRegion.Columns.Count - 1
For i = LBound(buf) To UBound(buf)
Set Target = .Range("A1:A65536").Find(What:=buf(i, 1) _
, LookAt:=xlPart, MatchCase:=False, MatchByte:=False)
If Not Target Is Nothing Then
For j = LBound(buf) To n
Target.Offset(, num + j).Value = buf(i, j)
Next j
End If
Next i
End With
Set objB = Nothing
Set Target = Nothing
End Sub
Goldenさん
ありがとうございました！！大変レスが遅くなりまして申し訳ありません。
すっきりできていて勉強になります。
ただ問題は、fileBにのみ載っている行が出ません。
トピ立てにも書いたような仕上がりを目指しています。
この点を直せるか考えてから、必要があれば質問とともにコメントを書こうと思っていたのですが、時間がとれずまだ考えてません。すいません。
Goldenさんのコメントをいただく前に考えていたのは、fileAとBいずれかに載っている全てのIDを重複無く揃えてしまってから、他の情報を貼る、、という方法です。IDを揃えてしまうのは以下のが使えるかなと。
http://officetanaka.net/excel/vba/tips/tips14.htm
これとGoldenさんのを組み合わせれば解決できるかなと思います。これから試してみます。
その他まだなにかコメントいただければ、全く別法でも勉強になりますのでお願いします。
余談ですけれど2008 for macってマクロ使えないのですね。
ありがとうございました！！大変レスが遅くなりまして申し訳ありません。
すっきりできていて勉強になります。
ただ問題は、fileBにのみ載っている行が出ません。
トピ立てにも書いたような仕上がりを目指しています。
この点を直せるか考えてから、必要があれば質問とともにコメントを書こうと思っていたのですが、時間がとれずまだ考えてません。すいません。
Goldenさんのコメントをいただく前に考えていたのは、fileAとBいずれかに載っている全てのIDを重複無く揃えてしまってから、他の情報を貼る、、という方法です。IDを揃えてしまうのは以下のが使えるかなと。
http://officetanaka.net/excel/vba/tips/tips14.htm
これとGoldenさんのを組み合わせれば解決できるかなと思います。これから試してみます。
その他まだなにかコメントいただければ、全く別法でも勉強になりますのでお願いします。
余談ですけれど2008 for macってマクロ使えないのですね。
Excelにはない用語など使いますので
説明について、意味がわからないところがあったらスルーしてください。
データベースでいうところの完全外部結合(FULL OUTER JOIN)をされたいようですね。
であれば、そのまんまをコードにすれば簡単に実装できるのですが・・・
主キーとなるID以外の項目がかぶらなければ列数がいくら増えても対応できますし。
しかし、私ならADOを使って実装すると思うのですが、
それがMacで動くかどうかは(Mac環境がないので)わからないですねぇ。
ADOでは完全外部結合ができないような気がしたので、
そうであれば左外部結合したものと右外部結合したものをUNIONすればできますね。
説明について、意味がわからないところがあったらスルーしてください。
データベースでいうところの完全外部結合(FULL OUTER JOIN)をされたいようですね。
であれば、そのまんまをコードにすれば簡単に実装できるのですが・・・
主キーとなるID以外の項目がかぶらなければ列数がいくら増えても対応できますし。
しかし、私ならADOを使って実装すると思うのですが、
それがMacで動くかどうかは(Mac環境がないので)わからないですねぇ。
ADOでは完全外部結合ができないような気がしたので、
そうであれば左外部結合したものと右外部結合したものをUNIONすればできますね。
ぬぉぉぉ！ コメントがついてる...
AとB両方に対応させて重複は削除だったのですね。
失礼しましたm(__)m
そして、マックは環境がないので解りません...ごめんなさい。
重複の削除はXL2007では簡単です。
ただ、それ以前の場合はエラーになりますので以下のようにしました。
If Not CInt(Application.Version) < 12 Then
With ActiveSheet.Range("A1").CurrentRegion
On Error Resume Next
.RemoveDuplicates Columns:=1, Header:=xlNo
On Error GoTo 0
End With
End If
オートフィルタを使い、重複を非表示にしてコピペするとこんな感じでしょうか。
With Sheets("Sheet1").Range("A1").CurrentRegion
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("Sheet2").Range("A1")
End With
Sheets("Sheet1").ShowAllData
私は、よっちゃんさんの方法をぜひ教えていただきたいとおもいます。
AとB両方に対応させて重複は削除だったのですね。
失礼しましたm(__)m
そして、マックは環境がないので解りません...ごめんなさい。
重複の削除はXL2007では簡単です。
ただ、それ以前の場合はエラーになりますので以下のようにしました。
If Not CInt(Application.Version) < 12 Then
With ActiveSheet.Range("A1").CurrentRegion
On Error Resume Next
.RemoveDuplicates Columns:=1, Header:=xlNo
On Error GoTo 0
End With
End If
オートフィルタを使い、重複を非表示にしてコピペするとこんな感じでしょうか。
With Sheets("Sheet1").Range("A1").CurrentRegion
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("Sheet2").Range("A1")
End With
Sheets("Sheet1").ShowAllData
私は、よっちゃんさんの方法をぜひ教えていただきたいとおもいます。
Goldenさんへ
> 私は、よっちゃんさんの方法をぜひ教えていただきたいとおもいます。
方法は提示しましたので、「コードを・・・」ということですね^^
[前提条件]
このマクロを書くブックのSheet1にファイルAの内容を記載。
このマクロを書くブックのSheet2にファイルBの内容を記載。
実行結果はSheet3に書き出すのでSheet3シートは用意しておいてください。
※画像参照
'--- ここからコード ----------------------
Option Explicit
Sub Sample()
Dim cn As Object
Dim rs As Object
Dim sql As String
Dim dataCell As Range
Dim i As Long
Dim buf As String
Worksheets("Sheet3").Cells.Clear
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
sql = "select [Sheet1$].ID, [Sheet1$].年齢, [Sheet1$].性別, [Sheet2$].住所, [Sheet2$].電話番号 from [Sheet1$] left outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID union select [Sheet2$].ID, [Sheet1$].年齢, [Sheet1$].性別, [Sheet2$].住所, [Sheet2$].電話番号 from [Sheet1$] right outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID"
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Open ThisWorkbook.FullName
rs.Open sql, cn
End With
For i = 0 To rs.Fields.Count - 1 Step 1
Worksheets("Sheet3").Cells(1, i + 1).Value = rs.Fields.Item(i).Name
Next i
Set dataCell = Worksheets("Sheet3").Range("A1").CurrentRegion
Do Until rs.EOF
For i = 0 To rs.Fields.Count - 1 Step 1
buf = buf & "," & rs.Fields.Item(i)
Next i
buf = Right$(buf, Len(buf) - 1)
dataCell.Offset(1) = Split(buf, ",")
Set dataCell = dataCell.Offset(1)
buf = vbNullString
rs.MoveNext
Loop
cn.Close
End Sub
'--- ここまでコード ----------------------
ADOを使ってExcelに接続して、SQL実行結果を並べているだけのコードです。
エラー処理は特にいれてませんので必要に応じて入れ込んでみてください
コードはほぼ定型(←これ重要！^^)なので、
SQL文さえ書ければ応用できることは多いです。
もちろん、データベース(この場合はExcelワークブック)は
自ブックである必要はありません。
デリミタは半角カンマとしてますが、
取得されるデータにカンマが入る可能性があるのであれば改行コードにしたり、
chr$(文字コード)にしたりで使われないであろう値にしておくのがよいかと。
SQLは、今回の例にあうように書きましたが、
列数が多くなるようであれば
sql = "select * from [Sheet1$] left outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID union select * from [Sheet1$] right outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID"のようにして、あとは結果から必要データをVBAでもExcelの数式ででも取ればよいかと。
ご参考になったでしょうか。
> 私は、よっちゃんさんの方法をぜひ教えていただきたいとおもいます。
方法は提示しましたので、「コードを・・・」ということですね^^
[前提条件]
このマクロを書くブックのSheet1にファイルAの内容を記載。
このマクロを書くブックのSheet2にファイルBの内容を記載。
実行結果はSheet3に書き出すのでSheet3シートは用意しておいてください。
※画像参照
'--- ここからコード ----------------------
Option Explicit
Sub Sample()
Dim cn As Object
Dim rs As Object
Dim sql As String
Dim dataCell As Range
Dim i As Long
Dim buf As String
Worksheets("Sheet3").Cells.Clear
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
sql = "select [Sheet1$].ID, [Sheet1$].年齢, [Sheet1$].性別, [Sheet2$].住所, [Sheet2$].電話番号 from [Sheet1$] left outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID union select [Sheet2$].ID, [Sheet1$].年齢, [Sheet1$].性別, [Sheet2$].住所, [Sheet2$].電話番号 from [Sheet1$] right outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID"
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Open ThisWorkbook.FullName
rs.Open sql, cn
End With
For i = 0 To rs.Fields.Count - 1 Step 1
Worksheets("Sheet3").Cells(1, i + 1).Value = rs.Fields.Item(i).Name
Next i
Set dataCell = Worksheets("Sheet3").Range("A1").CurrentRegion
Do Until rs.EOF
For i = 0 To rs.Fields.Count - 1 Step 1
buf = buf & "," & rs.Fields.Item(i)
Next i
buf = Right$(buf, Len(buf) - 1)
dataCell.Offset(1) = Split(buf, ",")
Set dataCell = dataCell.Offset(1)
buf = vbNullString
rs.MoveNext
Loop
cn.Close
End Sub
'--- ここまでコード ----------------------
ADOを使ってExcelに接続して、SQL実行結果を並べているだけのコードです。
エラー処理は特にいれてませんので必要に応じて入れ込んでみてください
コードはほぼ定型(←これ重要！^^)なので、
SQL文さえ書ければ応用できることは多いです。
もちろん、データベース(この場合はExcelワークブック)は
自ブックである必要はありません。
デリミタは半角カンマとしてますが、
取得されるデータにカンマが入る可能性があるのであれば改行コードにしたり、
chr$(文字コード)にしたりで使われないであろう値にしておくのがよいかと。
SQLは、今回の例にあうように書きましたが、
列数が多くなるようであれば
sql = "select * from [Sheet1$] left outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID union select * from [Sheet1$] right outer join [Sheet2$] on [Sheet1$].ID = [Sheet2$].ID"のようにして、あとは結果から必要データをVBAでもExcelの数式ででも取ればよいかと。
ご参考になったでしょうか。
よく、Bookを開かずにデータを読み込む処理はこんな感じでしょうか。
無駄な処理等あったら教えてください。
実行ファイルのフォルダにあるSampleBook1.xlsのSheet1のデータを取り込みます。
Option Explicit
Sub Macro1()
Const FILE_NAME As String = "SampleBook1.xls"
Dim cn As Object
Dim rs As Object
Dim sql As String
Dim cnc As String
Dim i As Long
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
sql = "select * from [Sheet1$]"
cnc = "Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & ThisWorkbook.Path & "\" & FILE_NAME & ";"
With cn
.Open "Provider=MSDASQL;" & cnc
rs.Open sql, cn
End With
Worksheets.Add
With rs
For i = 1 To .Fields.Count
Cells(1, i).Value = .Fields.Item(i - 1)
Next i
Range("A2").CopyFromRecordset rs
.Close
cn.Close
End With
Set rs = Nothing
Set cn = Nothing
End Sub
無駄な処理等あったら教えてください。
実行ファイルのフォルダにあるSampleBook1.xlsのSheet1のデータを取り込みます。
Option Explicit
Sub Macro1()
Const FILE_NAME As String = "SampleBook1.xls"
Dim cn As Object
Dim rs As Object
Dim sql As String
Dim cnc As String
Dim i As Long
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
sql = "select * from [Sheet1$]"
cnc = "Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & ThisWorkbook.Path & "\" & FILE_NAME & ";"
With cn
.Open "Provider=MSDASQL;" & cnc
rs.Open sql, cn
End With
Worksheets.Add
With rs
For i = 1 To .Fields.Count
Cells(1, i).Value = .Fields.Item(i - 1)
Next i
Range("A2").CopyFromRecordset rs
.Close
cn.Close
End With
Set rs = Nothing
Set cn = Nothing
End Sub
- mixiユーザー
- ログインしてコメントしよう！
|
|
|
|
