おやぢチップス (100)：別シートにデータをコピー（Excel - VBA）

またもや支援ネタ・・・

　　毎日こんなことばかりやっています。
　　ブログの更新が間遠くなったので、記事にします　(^-^;

MSDN Forum に質問がありました・・・

　　Excel で別シートにデータをコピーしたい。
　　ただし、既に存在するデータはコピーせず、見つからない場合にだけコピーしたい。
　　どんなコードを書けばいいの？・・・というものです。

なので、サンプルコードを書いてみました。

　　なお、２つのシートは同じ Excel ブック中にあるものとします。
　　コピー元のシートを Source、コピー先のシートを Target としています。

　　マッチングするためのキーは「都市」です。
　　コピー先にない都市ならコピーします。

画像はこんな感じ・・・
　　

VBA コードは次のとおりです。

　　英文の質問だったので、コードのコメントも英文（もどき）にしています。
　　時間がとれたら、まともな日本語のコメントにしたいと思います・・・
　　（シート上のヘッダーだけはこの記事用に直しました）

==== ▼▼ ここから ==============================

' === [Transfer Data] button（on sheet1: one Loop, using Find ==========
Private Sub btn_TransferData_Click()
Application.ScreenUpdating = False
' --- get lastRow both sheet1(source) & sheet2(target)
Dim lastRowSource As Integer
Dim lastRowTarget As Integer
lastRowSource = Sheets("Source").Cells(Rows.Count, 2).End(xlUp).Row ' --[City] is in column B:2
lastRowTarget = Sheets("Target").Cells(Rows.Count, 1).End(xlUp).Row ' --[City] is in column A:1
'MsgBox " lastRowSource=" & lastRowSource & Chr(13) & " lastRowTarget=" & lastRowTarget
' --- nested loop [For-Next]
Dim rowSource As Integer
Dim targetRow As Integer
targetRow = lastRowTarget
' --- set targetRange in sheet2 ([City] is column A)
Dim targetRange As Range
Set targetRange = Sheets("Target").Range("A2:A9999")
Dim FoundCell As Range
' --- [For-Next] loop: sheet1(source)
For rowSource = 2 To lastRowSource
' --- Find [City] in targetRange: keyword is [City]
Set FoundCell _
= targetRange.Find _
(What:=Sheets("Source").Cells(rowSource, 2).Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
MatchCase:=xlYes)
' --- [City] is not found in sheet2
If (FoundCell Is Nothing) Then
' --- copy data from souce to target
targetRow = targetRow + 1
Sheets("Target").Cells(targetRow, 1).Value _
= Sheets("Source").Cells(rowSource, 2).Value
Sheets("Target").Cells(targetRow, 2).Value _
= Sheets("Source").Cells(rowSource, 3).Value
Sheets("Target").Cells(targetRow, 3).Value _
= Sheets("Source").Cells(rowSource, 1).Value
End If
Next
' ---
Sheets("Target").Select
Sheets("Target").Cells(lastRowTarget + 1, 1).Select
' ---
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

==== ▲▲ ここまで ==============================

---------------------------------------------------------
ブログ記事についてのお問い合わせは「質疑応答 掲示板」で・・・

　　＃　ご質問にはできる限りお答えしています。
　　　　ただし、お名前（本名）を書いていただいた場合に限らせていただきます。


ここをクリックして、北窓舎のサイトにもお立ち寄りください・・・