| |
こんな物では？
File選択のダイアログがExcel2002以降用ですので、
それ以外の場合は別なプロシージャと入れ替えます
Sheet1のB2に数学の抽出平均点下限、C2に数学の抽出平均点上限
同じく、B3に英語の抽出平均点下限、C3に英語の抽出平均点上限を記入して実行します
Option Explicit
Public Sub DataExtract()
Dim i As Long
Dim vntInFiles As Variant
Dim dfo As Integer
Dim vntOutput As Variant
Dim strPath As String
Dim vntMark As Variant
Dim strProm As String
'指定形式のファイル名を取得
strPath = ThisWorkbook.Path & "\"
If Not GetReadFile(vntInFiles, strPath, True, "抽出元Fileを複数選択して下さい") Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'出力ファイル名を取得
If Not GetWriteFile(vntOutput, strPath, "抽出先Fileを指定して下さい") Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'抽出する下限、上限値を取得
vntMark = Worksheets("Sheet1").Cells(2, "B").Resize(2, 2).Value
'出力ファイルをOpen
dfo = FreeFile
Open vntOutput For Output As dfo
For i = 1 To UBound(vntInFiles)
'データの読み込み
CSVRead vntInFiles(i), dfo, vntMark
Next i
Close dfo
strProm = "処理が完了しました"
Wayout:
MsgBox strProm, vbInformation
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
dfo As Integer, _
vntMark As Variant, _
Optional strDelim As String = ",")
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
Dim lngMax As Long
'ファイルをOpen
dfn = FreeFile
Open strFileName For Input As dfn
Do Until EOF(dfn)
'１行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'論理レコードをフィールドに分割
vntField = SplitCsv(strRec, strDelim, , , blnMulti)
'フィールド内で改行が有る場合
If Not blnMulti Then
If vntField(0) <> "" Then
lngMax = UBound(vntField)
'数学の上下限で且つ英語の上下限に入るなら
If vntMark(1, 1) <= Val(vntField(lngMax - 1)) _
And Val(vntField(lngMax - 1)) <= vntMark(1, 2) Then
If vntMark(2, 1) <= Val(vntField(lngMax)) _
And Val(vntField(lngMax)) <= vntMark(2, 2) Then
Print #dfo, strRec
End If
End If
End If
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbCrLf
End If
Loop
Close #dfn
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
Dim i As Long
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim vntField As Variant
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)
If lngDPos = lngLength Then
ReDim Preserve vntData(i + 1)
End If
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)
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = Empty
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, _
Optional strTitle As String) As Boolean
' FileDialog使用版
Dim i As Long
Dim objFDL As FileDialog
Dim vntSelected As Variant
Dim vntFilters As Variant
'Filterを指定
vntFilters = Array("CSV File", "*.csv", "Text File", "*.txt", _
"CSV and Text", "*.csv;*.txt", "全て", "*.*")
'[ファイル参照] ダイアログの FileDialog オブジェクトを作成
Set objFDL = Application.FileDialog(msoFileDialogFilePicker)
'Show メソッドでダイアログを表示し、ユーザーのアクションを取得
With objFDL
'タイトルを設定
If strTitle <> "" Then
.Title = strTitle
End If
'初期フォルダ及び、指定ファイル名を設定
If strFilePath <> "" Then
.InitialFileName = strFilePath
End If
'Filterを設置
With .Filters
.Clear
For i = 0 To UBound(vntFilters) Step 2
.Add vntFilters(i), vntFilters(i + 1), i \ 2 + 1
Next i
End With
'表示するFilterを設定
.FilterIndex = 1
'MultiSelectを設定
.AllowMultiSelect = blnMultiSel
'ユーザーがボタンをクリック
If .Show = -1 Then
If blnMultiSel Then
'ファイル名保存する配列を確保
ReDim vntFileNames(1 To .SelectedItems.Count)
'FileDialogSelectedItemsコレクション内のすべてのファイル名を取得
i = 0
For Each vntSelected In .SelectedItems
'選択した各アイテムのパスを含む値を取得
i = i + 1
vntFileNames(i) = vntSelected
Next vntSelected
Else
vntFileNames = .SelectedItems(1)
End If
'戻り値としてTrueを返す
GetReadFile = True
End If
End With
Set objFDL = Nothing
End Function
Private Function GetWriteFile(vntFileName As Variant, _
Optional strFilePath As String, _
Optional strTitle As String) As Boolean
' FileDialog使用版
Dim i As Long
Dim objFDL As FileDialog
Dim vntSelected As Variant
'[ファイル参照] ダイアログの FileDialog オブジェクトを作成
Set objFDL = Application.FileDialog(msoFileDialogSaveAs)
'Show メソッドでダイアログを表示し、ユーザーのアクションを取得
With objFDL
'タイトルを設定
If strTitle <> "" Then
.Title = strTitle
End If
'初期フォルダ及び、指定ファイル名を設定
If strFilePath <> "" Then
.InitialFileName = strFilePath
End If
'表示するFilterを設定
.FilterIndex = 15 '★変更が必要かも？
'MultiSelectを設定
.AllowMultiSelect = False
'ユーザーがボタンをクリック
If .Show = -1 Then
vntFileName = .SelectedItems(1)
'戻り値としてTrueを返す
GetWriteFile = True
End If
End With
Set objFDL = Nothing
End Function
|
|
Hirofumi
- 10/11/27(土) 10:31 -
