| |
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngName As Range
Dim vntName As Variant
Dim rngColor As Range
Dim vntColor As Variant
Dim rngResult As Range
Dim lngFound As Long
Dim strProm As String
'Sheet1Listの左上隅セル位置を基準として設定(列見出し「番号」のセル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'Sheet2Listの左上隅セル位置を基準として設定(列見出し「番号」のセル位置)
Set rngName = Worksheets("Sheet2").Cells(1, "A")
'Sheet1Listの左上隅セル位置を基準として設定(列見出し「Col」のセル位置)
Set rngColor = Worksheets("Sheet3").Cells(1, "A")
With rngName
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = .Parent.Name & "のデータが有りません"
GoTo Wayout
End If
'Sheet2の「番号」列範囲を取得
Set rngName = .Offset(1).Resize(lngRows)
End With
With rngColor
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = .Parent.Name & "のデータが有りません"
GoTo Wayout
End If
'Sheet3の「Col」列範囲を取得
Set rngColor = .Offset(1).Resize(lngRows)
End With
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = .Parent.Name & "のデータが有りません"
GoTo Wayout
End If
'「番号」データを配列に取得
vntName = .Resize(lngRows + 1).Value
'「Col」データを配列に取得
vntColor = .Offset(, 2).Resize(lngRows + 1).Value
End With
'新規Bookを追加し先頭シートを結果シートとする
Set rngResult = Workbooks.Add.Worksheets(1).Cells(1, "A")
'Sheet1のデータ結果シートにCopy
rngList.Resize(lngRows + 1, 4).Copy Destination:=rngResult
'結果シートに列を挿入
With rngResult
.Offset(, 3).EntireColumn.Insert
.Offset(, 1).EntireColumn.Insert
End With
'列見出しを代入
vntName(1, 1) = rngName(1).Offset(-1, 1).Value
'列見出しを代入
vntColor(1, 1) = rngColor(1).Offset(-1, 1).Value
'探索
For i = 2 To lngRows + 1
'氏名を探索
lngFound = RowSearch(vntName(i, 1), rngName)
If lngFound > 0 Then
vntName(i, 1) = rngName(lngFound, 2).Value
End If
'Colを探索
lngFound = RowSearch(vntColor(i, 1), rngColor)
If lngFound > 0 Then
vntColor(i, 1) = rngColor(lngFound, 2).Value
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
With rngResult
'氏名を出力
.Offset(, 1).Resize(lngRows + 1).Value = vntName
'Colを出力
.Offset(, 4).Resize(lngRows + 1).Value = vntColor
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngName = Nothing
Set rngColor = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function RowSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngMode As Long = 1) As Long
Dim vntFind As Variant
If rngScope Is Nothing Then
lngOver = 1
Exit Function
End If
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngMode)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
RowSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
Else
lngOver = 1
End If
End Function
|
|
Hirofumi
- 06/12/3(日) 19:45 -
