| |
こんなのでは
Option Explicit
Option Compare Text
Public Sub Main()
Dim i As Long
Dim wkbFrom As Workbook
Dim wkbTo As Workbook
Dim vntFrom As Variant
Dim vntTo As Variant
'経費計画Bookのシート名を列挙
vntFrom = Array("東京支店", "横浜支店")
'経費実績Bookのシート名を列挙
vntTo = Array("東京支店", "横浜支店")
Set wkbFrom = Workbooks("経費計画.xls")
Set wkbTo = Workbooks("経費計画.xls")
Application.ScreenUpdating = False
For i = 0 To UBound(vntFrom)
Post wkbFrom.Worksheets(vntFrom(i)).Range("A1"), _
wkbTo.Worksheets(vntTo(i)).Range("A1")
Next i
Application.ScreenUpdating = True
Set wkbFrom = Nothing
Set wkbTo = Nothing
MsgBox "処理が完了しました", vbInformation
End Sub
Private Sub Post(rngFrom As Range, rngTo As Range)
'経費実績の列数（A〜B列）
Const clngColumns1 As Long = 2
'経費実績の中のKeyと成る列位置(基準列からのA列の列Offset：0列目)
Const clngKey1 As Long = 0
'転記先先頭列位置(基準列からのB列の列Offset：1列目)
Const clngItem1 As Long = 1
'経費計画の列数（A〜B列）
Const clngColumns2 As Long = 2
'経費計画の中のKeyと成る列位置(基準列からのA列の列Offset：0列目)
Const clngKey2 As Long = 0
'転記元先頭列位置(基準列からのQ列の列Offset：1列目)
Const clngItem2 As Long = 1
Dim i As Long
Dim j As Long
Dim lngRows1 As Long, lngRows2 As Long
Dim vntKeys1() As Variant, vntKeys2() As Variant
Dim vntData1() As Variant, vntData2() As Variant
Dim rngResult As Range
Dim lngStart As Long
With rngTo
'行数の取得
lngRows1 = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row + 1
If lngRows1 <= 1 And .Value = "" Then
Exit Sub
End If
'復帰用Keyを設定
.Offset(, clngColumns1).EntireColumn.Insert
With .Offset(, clngColumns1)
.Value = 1
.Resize(lngRows1).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
'A列をKeyとして整列
.Resize(lngRows1, clngColumns1 + 1).Sort _
Key1:=.Offset(, clngKey1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key列データを配列に取得
vntKeys1 = .Offset(, clngKey1).Resize(lngRows1 + 1).Value
End With
'結果用配列を確保
ReDim vntData1(1 To lngRows1, 1 To 1)
With rngFrom
'行数の取得
lngRows2 = .Offset(Rows.Count - .Row, clngKey2).End(xlUp).Row - .Row + 1
If lngRows2 <= 1 And .Value = "" Then
Exit Sub
End If
'復帰用Keyを設定
.Offset(, clngColumns2).EntireColumn.Insert
With .Offset(, clngColumns2)
.Value = 1
.Resize(lngRows2).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End With
'L列をKeyとして整列
.Resize(lngRows2, clngColumns2 + 1).Sort _
Key1:=.Offset(, clngKey2), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key列データを配列に取得
vntKeys2 = .Offset(, clngKey2).Resize(lngRows2 + 1).Value
'転記データを配列として取得
vntData2 = .Offset(, clngItem2).Resize(lngRows2).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)
Exit For
End If
End If
Next j
If j <= lngRows1 Then
lngStart = j
Else
Exit For
End If
Next i
'結果を出力
With rngTo
.Offset(, clngItem1).Resize(lngRows1, 2).Value = vntData1
'作業列をKeyとして整列
.Resize(lngRows1, clngColumns1 + 1).Sort _
Key1:=.Offset(, clngColumns1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'作業列を削除
.Offset(, clngColumns1).EntireColumn.Delete
End With
With rngFrom
'作業列をKeyとして整列
.Resize(lngRows2, clngColumns2 + 1).Sort _
Key1:=.Offset(, clngColumns2), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'作業列を削除
.Offset(, clngColumns2).EntireColumn.Delete
End With
End Sub
|
|
Hirofumi
- 10/12/20(月) 23:44 -
