[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルの中身・列を指定してのCSV取り出し』（草薙）
はじめまして。
現在、4万ライン・列が50行ほどあるCSVデータの中から、集計用のマクロを作りたいと
悪戦苦闘しております。
列：５０列の中から４・５・７・１２・１３列目だけを読み込み。
更に、その12列目の中から特定の地名『秋田・長野・埼玉・群馬・北海道』だけを選んでエクセルに書き出したいと思っています。
完全に素人なので、いろいろネットや参考書を調べながら自分なりに書いてみたのですが・・・
Sub READ()
Dim Strfile As String
Dim Vanfile As String
Dim apl As Application
Const CTitle = "テキストファイル読み込み"
Const CFilter = "csv形式ファイル (*.csv),*.CSV,全てのファイル(*.*),*.*"
Set apl = Application
apl.StatusBar = "読み込むファイルの指定"
Vanfile = apl.GetOpenFilename(FileFilter:=CFilter, _
title:=CTitle)
If VarType(Vanfile) = vbBoolean Then Exit Sub
Strfile = Vanfile
Workbooks.OpenText Filename:=Strfile, DataType:=xlDelimited, _
Comma:=True, FieldInfo:=Array(Array(1, 9), Array(2, 9), Array(3, 9), _
Array(4, 1), Array(5, 1), Array(6, 9), Array(7, 1), Array(8, 9), _
Array(9, 9), Array(10, 9), Array(11, 9), Array(12, 1), Array(13, 1), _
Array(14, 9), Array(15, 9), Array(16, 9), Array(17, 9), Array(18, 9), _
Array(19, 9), Array(20, 9), Array(21, 9), Array(22, 9), Array(23, 9), _
Array(24, 9), Array(25, 9), Array(26, 9), Array(26, 9), Array(27, 9), _
Array(29, 9), Array(30, 9), Array(31, 9), Array(32, 9), Array(33, 9), _
Array(34, 9), Array(35, 9), Array(36, 9), Array(37, 9), Array(38, 9), _
Array(39, 9), Array(40, 9), Array(41, 9), Array(42, 9), Array(43, 9), _
Array(44, 9), Array(45, 9), Array(46, 9), Array(47, 9), Array(48, 9), _
Array(49, 9), Array(50, 9))
End Sub
とりあえず『必要な列だけを取り出して読み込み』までを作ってみたつもりですが、
なぜか元となるcsvのデータが全部出てきてしまいました。
マクロを動かしてもエラーもなくcsvファイルが展開されてしまうため、自分でも何が原因で全部読み込まれてしまうのかが分かりません。
恐れ入りますが、どなたか間違いの場所を教えていただけるでしょうか？
エクセルは2003でOSはxpです。よろしくお願いします。
それが遅いのならＳＱＬ文で条件指定して取り出す方法もあります。
Excel、ＣＳＶ、ＳＱＬ等で検索してみてはどうでしょうか?（偽のマダラ）
拡張子をcsvから、txtに変えれば望みの事ができますけど。 尚、csvファイルをOpenTextで開くと、とてつもなく時間がかかります。 BJ
テキストファイルウィザードの動作にて不要列の削除の再現は確認できました。
ただ、テキストファイルからの読み込みはクエリのようにデータの絞込みを
同時にできないので、いったんエクセルブックに取り込んでから
フィルタで絞り込み処理をするようになると思います。
（みやほりん）
ADOでSQL使って抽出する方が多分圧倒的に速いと思いますが？ Openステートメントを使ってシートに抽出します CSVからデータの取得に少し無理を行っていますのでリソースの状態でリソース不足が出るかも？
Option Explicit
Public Sub Sample_1()
Const CTitle = "テキストファイル読み込み"
Const CFilter = "csv形式ファイル (*.csv),*.CSV,全てのファイル(*.*),*.*"
Dim lngWrite As Long
Dim rngList As Range
Dim vntFname As Variant
Dim vntData As Variant
Dim strPrompt As String
'読み込むCSVファイルの選択
vntFname = Application.GetOpenFilename(FileFilter:=CFilter, Title:=CTitle)
If VarType(vntFname) = vbBoolean Then
Exit Sub
End If
'結果を出力する先頭位置を設定
Set rngList = ActiveSheet.Range("A1")
'CSVファイルからデータ取得
vntData = GetData(vntFname)
'CSVデータから列データを抽出
vntData = GetColumnsData(vntData, lngWrite)
'結果をシートに書き込み
With rngList
.Parent.UsedRange.ClearContents
If lngWrite > 0 Then
.Resize(lngWrite, UBound(vntData, 2)).Value = vntData
End If
End With
strPrompt = "処理が完了しました"
Wayout:
Set rngList = Nothing
MsgBox strPrompt, vbInformation
End Sub
Private Function GetData(vntFname As Variant) As Variant
Dim i As Long
Dim dfn As Integer
Dim bytBuff() As Byte
Dim vntData As Variant
'ファイルをOpen
dfn = FreeFile
Open vntFname For Binary As dfn
'読み込み用バッファを確保
ReDim bytBuff(1 To LOF(dfn))
'データの読み込み
Get #dfn, , bytBuff
'ファイルをClose
Close #dfn
'データを改行文字で分割
vntData = Split(StrConv(bytBuff, vbUnicode), vbCrLf)
'不要行を削除
For i = UBound(vntData) To 0 Step -1
If Trim(vntData(i)) <> "" Then
Exit For
End If
Next i
ReDim Preserve vntData(i)
GetData = vntData
End Function
Private Function GetColumnsData(vntData As Variant, lngEnd As Long) As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim vntField As Variant
Dim vntResult As Variant
Dim lngEend As Long
Dim vntFNumb As Variant
Dim vntExtr As Variant
'抽出条件
vntExtr = Array("秋田*", "長野*", "埼玉*", "群馬*", "北海道*")
lngEend = UBound(vntExtr)
'抽出列
vntFNumb = Array(3, 4, 6, 11, 12)
'抽出したデータを書き込む配列を確保
ReDim vntResult(1 To UBound(vntData, 1) + 1, 1 To UBound(vntFNumb) + 1)
For i = 0 To UBound(vntData, 1)
'データをフィールドに分割
vntField = Split(vntData(i), ",")
'12列目の中から特定の地名だけ選択
For j = 0 To lngEend
If vntField(11) Like vntExtr(j) Then
Exit For
End If
Next j
'一致する物が在ったら
If j <= lngEend Then
'結果を書き込む
k = k + 1
For j = 0 To UBound(vntFNumb)
vntResult(k, j + 1) = vntField(vntFNumb(j))
Next j
End If
Next i
GetColumnsData = vntResult
lngEnd = k
End Function
(Bun)
アドバイス通り、SQL調べて見ました。すごく便利そうですが、まだ僕自身のレベルが追いついていないので、一朝一夕には難しそうです。
＞BJ様
はい。修正してみたら、結構時間がかかりました。
マニュアルのほうが早いくらいでした。
＞みやほりん様
自動記録は使ってみたのですが、自分が素人すぎて改変ポイントがいまいち分かりませんでした。というか、改造すると必ずエラーになってしまって・・・
＞Bun様
ご丁寧なコードを示して下さり、ありがとうございます！
今の自分にADOを使いこなす技術がなかったので、分かる範囲で最初はコードを書いてました。
時に、作ってくださった
If vntField(11) Like vntExtr(j) Then
ここの部分で、なぜか『インデックスが有効範囲にありません』というエラーが出てとまってしまいます。
これは、csvのほうに何か問題があるのでしょうか？
>時に、作ってくださった > >******************************************* > If vntField(11) Like vntExtr(j) Then >******************************************* > >ここの部分で、なぜか『インデックスが有効範囲にありません』というエラーが出てとまってしまいます。 >これは、csvのほうに何か問題があるのでしょうか？
此処で、『インデックスが有効範囲にありません』と出るのは、2つの原因が考えられると思いますが？
1、「vntExtr(j)」の「j」、詰まり配列変数vntExtrの要素数が「j」迄無い場合 しかし、
'抽出条件
vntExtr = Array("秋田*", "長野*", "埼玉*", "群馬*", "北海道*")
lngEend = UBound(vntExtr)
でArray()とし、変数に配列として代入して、配列の最大要素数をlngEendの取得していますので 考えにくいと思います
2、「vntField(11)」の方で『インデックスが有効範囲にありません』と出るので有れば 読み込んでいる、1レコードが12列（今回、フィールドは0から勘定しているので）未満の場合出ます 此方の可能性が大きいかな？
フィールドがダブルクォーツで括られている場合を今回、コードが長く成るのと遅く成るので対処を行っていません？ 其処で、CSVデータを調べて見て下さい
1、フィールドにダブルクォーツで括られた物が有るのか否か？ 此れは、CSVデータをテキストエディタで見て見ると解ると思います 2、もし、ダブルクォーツで括られたフィールドが有るならば、 ダブルクォーツで括られたフィールドに改行コードが有るか否か？ 此れは、テキストエディタでデータを見て行った場合見つけられると思います テキストエディタで上から見て行けば、本来50行（50フィールド）有るのに 急に短いレコードが出て来ますので、その行の最後を見て下さい、 例えば、「あああいいい」と言うデータ場合、「,"あああ」の様にダブルクォーツで括られいず 次の行の先頭が「いいい"、」と成って居ませんか？ (Access等から出力されたデータで偶に有る見たいです)
後は、上記にCSVデータの確認に因って対処が代わるので、データを調べてからに成ります
(Bun)
ありがとうございます。
＞1、フィールドにダブルクォーツで括られた物が有るのか否か？
アドバイス通り確認してみたところ、全てがダブルクオーツで括られておりました。
データはこんな感じでした。
"日程","名前"," 出身"," 性別","発空港","到着地","年齢"," CITY","営業支店","営業課","都道府県","既婚","家族","FLT NO.1","FLT NO.2","REMARK1","REMARK2","OTHER1","OTHER2","電話","携帯","メール1","メール2","メール3","連絡先他"
一応、ダブルクォーツの処理と、フィールドの改行コード(CrLF)が有った場合、Lfに代えて出力します また、フィールド数が12列未満の場合、処理を中止してCSVのどの行で其れが起きたかを表示します ただ此れを行うと処理が相当遅く成るので覚悟して下さい
Option Explicit
Public Sub Sample_2()
Const CTitle = "テキストファイル読み込み"
Const CFilter = "csv形式ファイル (*.csv),*.CSV,全てのファイル(*.*),*.*"
Dim lngWrite As Long
Dim rngList As Range
Dim vntFname As Variant
Dim strData() As String
Dim vntData As Variant
Dim strPrompt As String
'読み込むCSVファイルの選択
vntFname = Application.GetOpenFilename(FileFilter:=CFilter, Title:=CTitle)
If VarType(vntFname) = vbBoolean Then
Exit Sub
End If
'結果を出力する先頭位置を設定
Set rngList = ActiveSheet.Range("A1")
'CSVファイルからデータ取得
strData = GetData(vntFname)
'CSVデータから列データを抽出
strPrompt = GetColumnsData(strData, vntData, lngWrite)
If strPrompt <> "" Then
GoTo Wayout
End If
'結果をシートに書き込み
With rngList
.Parent.UsedRange.ClearContents
If lngWrite > 0 Then
.Resize(lngWrite, UBound(vntData, 2)).Value = vntData
End If
End With
strPrompt = "処理が完了しました"
Wayout:
Set rngList = Nothing
MsgBox strPrompt, vbInformation
End Sub
Private Function GetData(vntFname As Variant) As String()
Dim i As Long
Dim dfn As Integer
Dim bytBuff() As Byte
Dim strData() As String
'ファイルをOpen
dfn = FreeFile
Open vntFname For Binary As dfn
'読み込み用バッファを確保
ReDim bytBuff(1 To LOF(dfn))
'データの読み込み
Get #dfn, , bytBuff
'ファイルをClose
Close #dfn
'データを改行文字で分割
strData = Split(StrConv(bytBuff, vbUnicode), vbCrLf)
'不要行を削除
For i = UBound(strData) To 0 Step -1
If Trim(strData(i)) <> "" Then
Exit For
End If
Next i
ReDim Preserve strData(i)
GetData = strData
End Function
Private Function GetColumnsData(strData() As String, vntData As Variant, lngEnd As Long) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim vntField As Variant
Dim lngEend As Long
Dim vntFNumb As Variant
Dim vntExtr As Variant
Dim blnMulti As Boolean
Dim strBuff As String
'抽出条件
vntExtr = Array("秋田*", "長野*", "埼玉*", "群馬*", "北海道*")
lngEend = UBound(vntExtr)
'抽出列
vntFNumb = Array(3, 4, 6, 11, 12)
'抽出したデータを書き込む配列を確保
ReDim vntData(1 To UBound(strData, 1) + 1, 1 To UBound(vntFNumb) + 1)
For i = 0 To UBound(strData, 1)
strBuff = strBuff & strData(i)
'データをフィールドに分割
vntField = SplitCsv(strBuff, ",", , , blnMulti)
If blnMulti Then
strBuff = strBuff & vbLf
Else
If UBound(vntField) < 11 Then
GetColumnsData = "CSVの " & i & " 行目の列数が" & (UBound(vntField) + 1) & "列です！"
GoTo Wayout
End If
'12列目の中から特定の地名だけ選択
For j = 0 To lngEend
If vntField(11) Like vntExtr(j) Then
Exit For
End If
Next j
'一致する物が在ったら
If j <= lngEend Then
'結果を書き込む
k = k + 1
For j = 0 To UBound(vntFNumb)
vntData(k, j + 1) = vntField(vntFNumb(j))
Next j
End If
strBuff = ""
End If
Next i
Wayout:
lngEnd = k
End Function
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
' strLine :分割元と成る文字列 ' strDelimiter :区切り文字 ' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i 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) & strRet
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
(Bun)
重ね重ね、ありがとうございます。
うまくいきました・・・が、やはりおっしゃるとおり時間がかかりましたね。
ですが、コードの書き方といい、とても勉強になりました。
本当は、ADOとSQLの構文で作れる技術が自分にあれば、よいのでしょうが・・・
まだまだなので、精進いたします。
今回の疑問は、皆様のおかげで無事解決出来ました。
ありがとうございました。
草薙
実行はパスとファイル名の変更、ツールの設定をしてからお試し下さい。
（北海道の条件判定はちょっと端折っています。）
(Mook)
Const DRIVER As String = "DRIVER={Microsoft Text Driver (*.txt; *.csv)};DBQ="
Const PROVIDER As String = "Provider=MSDASQL;Extended Properties="""
Public Sub main()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
'接続文字列
'CSVファイルが保存されているフォルダ名を指定する
'ファイル名を指定するとエラーが発生するので注意!
cn.ConnectionString = PROVIDER & DRIVER & "C:\"""
cn.Open
Dim strSQL As String
' CSV ファイル名は実際のファイル名に修正
strSQL = "SELECT [出身],[性別],[到着地],[都道府県], [既婚] FROM Sample.csv " _
& " WHERE LEFT([都道府県],2) IN ('秋田','長野','埼玉','群馬','北海' )"
'CSVファイルの内容を取得
'最初の1行目は見出し行になるため、取得されない点に注意!
Set rs = cn.Execute(strSQL)
rs.MoveFirst
Dim idy As Long
Dim idx As Long
idy = 1
Do Until rs.EOF
For idx = 0 To rs.Fields.Count - 1
Cells(idy, idx + 1).Value = rs.Fields(idx).Value
Next idx
idy = idy + 1
rs.MoveNext
Loop
cn.Close
End Sub
わざわざ、本当にありがとうございます！
早いですね、これ！圧倒的に早いですねこれ！
コードもシンプルでとても分かりやすいです！
勉強になりました！
草薙
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.