|
こんなのでは?
Option Explicit
Option Compare Text
Public Sub Sample_1()
'ブックAの列数(B〜D列)
Const clngColumns1 As Long = 3
'ブックAの中のKeyと成る列位置(基準列からのB列の列Offset:0列目)
Const clngKey1 As Long = 0
'転記先先頭列位置(基準列からのC列の列Offset:1列目)
Const clngItem1 As Long = 1
'ブックBの列数(L〜R列)
Const clngColumns2 As Long = 7
'ブックBの中のKeyと成る列位置(基準列からのL列の列Offset:0列目)
Const clngKey2 As Long = 0
'転記元先頭列位置(基準列からのQ列の列Offset:5列目)
Const clngItem2 As Long = 5
Dim i As Long
Dim j As Long
Dim lngRows1 As Long, lngRows2 As Long
Dim rngList1 As Range, rngList2 As Range
Dim vntKeys1() As Variant, vntKeys2() As Variant
Dim vntData1() As Variant, vntData2() As Variant
Dim rngResult As Range
Dim lngStart As Long
Dim strPrompt As String
'ブックAの先頭セル位置を基準とする(先頭列の列見出しKeyのセル位置)
' Set rngList1 = Workbooks("ブックA.xls").Worksheets("シートA").Range("B1")
Set rngList1 = Worksheets("シートA").Range("B1")
'ブックBの先頭セル位置を基準とする(先頭列の列見出しKeyのセル位置)
' Set rngList2 = Workbooks("ブックB.xls").Worksheets("シートB").Range("L1")
Set rngList2 = Worksheets("シートB").Range("L1")
'画面更新を停止
Application.ScreenUpdating = False
With rngList1
'行数の取得
' lngRows1 = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
lngRows1 = 3131 - 2 + 1
If lngRows1 <= 0 Then
strPrompt = "データが有りません"
GoTo Wayout
End If
'復帰用Keyを設定
.Offset(, clngColumns1).EntireColumn.Insert
With .Offset(1, clngColumns1)
.Value = 1
.Resize(lngRows1).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
'B列をKeyとして整列
.Offset(1).Resize(lngRows1, clngColumns1 + 1).Sort _
Key1:=.Offset(1, clngKey1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key列データを配列に取得
vntKeys1 = .Offset(1, clngKey1).Resize(lngRows1 + 1).Value
End With
'結果用配列を確保
ReDim vntData1(1 To lngRows1, 1 To 2)
With rngList2
'行数の取得
' lngRows2 = .Offset(Rows.Count - .Row, clngKey2).End(xlUp).Row - .Row
lngRows2 = 303 - 2 + 1
If lngRows2 <= 0 Then
strPrompt = "データが有りません"
GoTo Wayout
End If
'復帰用Keyを設定
.Offset(, clngColumns2).EntireColumn.Insert
With .Offset(1, clngColumns2)
.Value = 1
.Resize(lngRows2).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
'L列をKeyとして整列
.Offset(1).Resize(lngRows2, clngColumns2 + 1).Sort _
Key1:=.Offset(1, clngKey2), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key列データを配列に取得
vntKeys2 = .Offset(1, clngKey2).Resize(lngRows2 + 1).Value
'転記データを配列として取得
vntData2 = .Offset(1, clngItem2).Resize(lngRows2, 2).Value
End With
'ブックAを検索して見つかったその行をブックAの「抽出データ」を転記
lngStart = 1
For i = 1 To lngRows1
For j = lngStart To lngRows2
''ブックAのKeyがブックBのKeyより大きければ
If vntKeys1(i, 1) < vntKeys2(j, 1) Then
'Forを抜ける
Exit For
Else
'ブックAのKeyとブックBのKey等しければ
If vntKeys1(i, 1) = vntKeys2(j, 1) Then
'出力用配列に転記
vntData1(i, 1) = vntData2(j, 1)
vntData1(i, 2) = vntData2(j, 2)
Exit For
End If
End If
Next j
If j <= lngRows1 Then
lngStart = j
Else
Exit For
End If
Next i
'結果を出力
With rngList1
.Offset(1, clngItem1).Resize(lngRows1, 2).Value = vntData1
'作業列をKeyとして整列
.Offset(1).Resize(lngRows1, clngColumns1 + 1).Sort _
Key1:=.Offset(1, clngColumns1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'作業列を削除
.Offset(, clngColumns1).EntireColumn.Delete
End With
With rngList2
'作業列をKeyとして整列
.Offset(1).Resize(lngRows2, clngColumns2 + 1).Sort _
Key1:=.Offset(1, clngColumns2), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'作業列を削除
.Offset(, clngColumns2).EntireColumn.Delete
End With
strPrompt = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strPrompt, vbInformation
End Sub
|
|