| |
社員のデータはCsvファイルで、以下の様に成っていると想定します
1,12,13,25
2,5,60,20
3,4,8,7
出力する、シートは、以下の様に成っていると想定します
NO C A
1
3
NOは、1行目A列に有る物とします
このコードでは、社員のデータのCsvファイルをBookに展開せず
Openステートメントを使って1行づつ読み込み、
ActiveWorkbookのActiveSheetのNoを探して書きこんで行きます
Dictionary オブジェクトが使える環境なら、簡単なコードでは有りませんが
Findで探すより幾らか早いと思います
以下を標準モジュールに記述して下さい
Option Explicit
Public Sub DataExtraction()
Dim i As Long
Dim j As Long
Dim dfn As Integer
Dim vntFileName As Variant
Dim strBuff As String
Dim vntField As Variant
Dim wksResult As Worksheet
Dim vntResult As Variant
Dim lngWrite As Long
Dim lngEnd As Long
Dim dicIndex As Object
'結果書き込みシートの参照を設定
Set wksResult = ActiveWorkbook.ActiveSheet
'書き込み行の初期値を設定
lngWrite = 2
'社員データのファイル名を取得
If Not GetReadFile(vntFileName, _
ThisWorkbook.Path, False) Then
GoTo ExitHandler
End If
With wksResult
'探索範囲（No）の有る最終行取得
lngEnd = .Cells(65536, "A").End(xlUp).Row
'探索範囲（No）が無い場合
If lngEnd < lngWrite Then
Beep
MsgBox "データが有りません"
GoTo ExitHandler
End If
'探索範囲（No）の値を配列に取得
vntResult = Range(.Cells(lngWrite, "A"), _
.Cells(lngEnd, "B")).Value
End With
'Dictionary オブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'社員データのファイルをOpen
dfn = FreeFile
Open vntFileName For Input As dfn
'Dictionaryに就いて
With dicIndex
For i = 1 To UBound(vntResult, 1)
'探索範囲（No）の値をdicIndexにセット、
.Add CLng(vntResult(i, 1)), i
'及び結果用配列を初期化
For j = 1 To 2
vntResult(i, j) = Empty
Next j
Next i
Do Until EOF(dfn)
'社員データから1行読み込み
Line Input #dfn, strBuff
'読み込んだレコードをフィールドに分割
vntField = SplitCsv(strBuff, ",")
'Dictionaryに有った場合
If .Exists(CLng(vntField(0))) Then
i = .Item(CLng(vntField(0)))
'結果用配列に列を入れ替えて代入
vntResult(i, 1) = vntField(3)
vntResult(i, 2) = vntField(1)
End If
Loop
End With
'社員データのファイルをClose
Close #dfn
'結果を結果用シートに出力
With wksResult
.Cells(lngWrite, _
"B").Resize(UBound(vntResult, 1), 2) _
= vntResult
End With
Beep
MsgBox "処理が終了しました"
ExitHandler:
Set wksResult = Nothing
Set dicIndex = Nothing
End Sub
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' Csvレコード分割関数
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As String
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = ""
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
' ファイル名取得関数
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt," _
& "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames, False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 04/3/21(日) 14:18 -
