Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

22037 / 76734

←次へ　｜　前へ→


	【60083】Re:データの統合について

ponpon - 09/1/27(火) 0:01 -


	引用なし

	パスワード

3つのworkbookは、すべて開いているもの
また、AAA.xls、BBBxlsのL列に重複がないものとして、

AAA.xls、BBBxls　それぞれのL列を見ていって、""でなければ、
その行をコピーして新規ブックに貼り付ける。
（配列に入れて一気にはき出した方が速いと思います。）

最後に並べ替えをする。

新規ブックに

Sub test()
　　Dim WB1 As Workbook
　　Dim WB2 As Workbook
　　Dim NWB As Workbook
　　Dim r As Range
　　
　　Set WB1 = Workbooks("AAA.xls")
　　Set WB2 = Workbooks("BBB.xls")
　　Set NWB = ThisWorkbook

　　Application.ScreenUpdating = False
　　With NWB.Sheets("Sheet1")
　　　　.Cells.Clear
　　　　.Range("A1:L1").Value = WB1.Sheets("Sheet1").Range("A1:L1").Value
　　End With
　　With WB1.Sheets("Sheet1")
　　　　For Each r In .Range(.Cells(2, "L"), .Cells(.Rows.Count, "L").End(xlUp))
　　　　　　If r <> "" Then
　　　　　　　 r.Offset(, -11).Resize(, 12).Copy NWB.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　End If
　　　　Next
　　End With
　　With WB2.Sheets("Sheet1")
　　　　For Each r In .Range(.Cells(2, "L"), .Cells(.Rows.Count, "L").End(xlUp))
　　　　　　If r <> "" Then
　　　　　　　 r.Offset(, -11).Resize(, 12).Copy NWB.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　End If
　　　　Next
　　End With
　　With NWB
　　　　 .Sheets("Sheet1").Range("A1").CurrentRegion.Sort Key1:=.Sheets("Sheet1").Range("A2"), _
　　　　　 Order1:=xlAscending, Header:=xlGuess
　　End With
　　Application.ScreenUpdating = True　　
End Sub

3 hits

▼

【60082】データの統合について mao 09/1/26(月) 22:26