Excel VBA質問箱 IV

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

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


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

22019 / 76734

←次へ　｜　前へ→


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

ponpon - 09/1/27(火) 15:08 -


	引用なし

	パスワード

>配列に入れて一気にはき出した方が速いと思います。
DIctionaryで作ってみました。
Sub test()
　　Dim myDic As Object
　　Dim WB1 As Workbook
　　Dim WB2 As Workbook
　　Dim NWB As Workbook
　　Dim r As Range
　　Dim i As Long
　　
　　
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set WB1 = Workbooks("AAA.xls")
　　Set WB2 = Workbooks("BBB.xls")
　　Set NWB = ThisWorkbook

　　Application.ScreenUpdating = False
　　With NWB.Sheets("Sheet1")
　　　　.Cells.ClearContents
　　　　.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
　　　　　　　 myDic(i) = r.Offset(, -11).Resize(, 12).Value
　　　　　　　 i = i + 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
　　　　　　　 myDic(i) = r.Offset(, -11).Resize(, 12).Value
　　　　　　　 i = i + 1
　　　　　　End If
　　　　Next
　　End With
　　With NWB.Sheets("Sheet1")
　　　　 .Range("A2").Resize(myDic.Count, 12).Value = Application.Transpose(Application.Transpose(myDic.Items))
　　　　 .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess
　　End With
　　Application.ScreenUpdating = True
End Sub

4 hits

▼

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