Excel VBA(エクセル マクロ) 小技集そのB データの追記

行の最終行にデータを追加指定していきたい。
しかし、重複して追加したくない。さて、どうしよう??

Excel VBAで、あるシートの行の最後にデータを追記する作業がある。

これも自動化する。

重複を避けたいため、行の中で他の行と重複しない値を取り出し、追記先にあるかどうかチェックして無ければコピーしていくことにした。

'データの末尾をlineに格納
Sheets("転記先").Select
line = 2
Do Until Cells(line, 1).Value = ""
line = line + 1
Loop

'PJが無ければ転記する。
Sheets("転記元").Select
line1 = 2
Do Until Cells(line1, 4).Value = ""
On Error Resume Next
If Application.WorksheetFunction.VLookup(Cells(line1, 4).Value, Worksheets("転記先").Range("D2:Y10000"), 1, 0) = "" Then
Worksheets("転記元").Rows(line1).Copy Worksheets("転記先").Rows(line)
line = line + 1
End If
On Error GoTo 0
line1 = line1 + 1
Loop


まず、転記先の最終行(空白になる部分)をlineに格納する。

Sheets("転記先").Select
line = 2
Do Until Cells(line, 1).Value = ""
line = line + 1
Loop

PJという題名の値が転記先に無ければ、その行を転記元からコピーする。
シート:転記元のCells(line1, 4)の値が転記先にあるかチェックし、あれば、転記先の最終行にコピーを行い、最終行の位置を1プラスする。
例のごとく、Do Until Cells(line1, 4).Value = ""で転記元すべての行について検索する。
コピーは行を指定するRowsを使用する。
Worksheets("転記元").Rows(line1).Copy Worksheets("転記先").Rows(line)


'PJが無ければ転記する。
Sheets("転記元").Select
line1 = 2
Do Until Cells(line1, 4).Value = ""
On Error Resume Next
If Application.WorksheetFunction.VLookup(Cells(line1, 4).Value, Worksheets("転記先").Range("D2:Y10000"), 1, 0) = "" Then
Worksheets("転記元").Rows(line1).Copy Worksheets("転記先").Rows(line)
line = line + 1 '転記先の最終行を1プラス
End If
On Error GoTo 0
line1 = line1 + 1 '転記元の行について1行ずつ検索する。
Loop

以上で、ワンボタンで「重複なし」にコピーすることが可能となった。


忍者Admaxのテキスト広告で収入UP!

実践!ExcelデータベースTOP