| |
こんなのでは？
Option Explicit
Option Compare Text
Public Sub Sample_1()
'ブックＡの列数（B〜D列）
Const clngColumns1 As Long = 3
'ブックＡの中のKeyと成る列位置(基準列からのB列の列Offset：0列目)
Const clngKey1 As Long = 0
'転記先先頭列位置(基準列からのC列の列Offset：1列目)
Const clngItem1 As Long = 1
'ブックＢの列数（L〜R列）
Const clngColumns2 As Long = 7
'ブックＢの中の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
'ブックＡの先頭セル位置を基準とする（先頭列の列見出しKeyのセル位置）
' Set rngList1 = Workbooks("ブックＡ.xls").Worksheets("シートＡ").Range("B1")
Set rngList1 = Worksheets("シートＡ").Range("B1")
'ブックＢの先頭セル位置を基準とする（先頭列の列見出しKeyのセル位置）
' Set rngList2 = Workbooks("ブックＢ.xls").Worksheets("シートＢ").Range("L1")
Set rngList2 = Worksheets("シートＢ").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
'ブックＡを検索して見つかったその行をブックＡの「抽出データ」を転記
lngStart = 1
For i = 1 To lngRows1
For j = lngStart To lngRows2
''ブックＡのKeyがブックＢのKeyより大きければ
If vntKeys1(i, 1) < vntKeys2(j, 1) Then
'Forを抜ける
Exit For
Else
'ブックＡのKeyとブックＢの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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
