[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『csvファイルと行削除を短縮』（あちゃこ）
処理時間の短縮を図ろうと思い、エクセルの学校の先生方にご指導いただきながら、 ごそごそやっています。マクロを習得することが先決なのですが、ちょっと違う方面も 。
csvファイルを所定のxlsファイルに全面貼り付けるのに33秒かかり、同じ内容のものを xlsに変えて貼り付けると僅か1秒です。 この差はあまりにも大きすぎるので、どうにかして短縮したいと思ってい csvファイルのままで全面貼り付けを短縮する方法を教えてください。 ファイルの大きさは5万行、95列で、Excel2003 WindowsXPです。
もう一つ この大きいcsvファイルで行削除するのに下記のようにオートフィルタをかけ2行目 以降を行削除すと非常に時間がかかります。短縮方法がありましたらご指導お願い します。
Range("A1").Select
Selection.AutoFilter Field:=14, Criteria1:="1"
Rows("2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=14
>csvファイルを所定のxlsファイルに全面貼り付けるのに33秒かかり、同じ内容のものを >xlsに変えて貼り付けると僅か1秒です。
この意味は、csvファイルをWorkbookとして開くと時間がかからないけど、 他の方法でcsvファイルとして呼び出して処理すると時間がかかるということ？
>この大きいcsvファイルで行削除するのに下記のようにオートフィルタをかけ
エクセル画面にはワークブックとして読み込まれている状態だよね。 であれば、csvファイルというより、一般にシートの削除をどうしたら短い処理時間でできるかという テーマだけど、そう考えていい？
追加で）要は"1"のものを消して"1"以外を残したいということだよね。
(ぶらっと)
とりあえず後者について。 [[20111014140154]] 『フィルターで検索した物を別シートにコピー後削除』 このスレにアップしたSample7が、フィルター結果、抽出された行を削除する定番コードだけど 以下の理由で今回は心配。
・AutoFilter.Range を相手にしているけど、抽出された領域は、内部的には、連続した領域ではなく飛び飛びの領域の集まり。 で、一般に2003では、このとびとびの領域が8192以上になると、とんでもないことになる。（全行が削除される） ・対象行数が多いと、「削除」という行為は、処理コストが大きい。
なので、お勧めは、フィルターオプションを使って、「"1”じゃないものを」別シートに抽出。 必要なら、元シートを削除して、別シートの名前を元シートの名前に変えておく。
(ぶらっと)
前者も、とりあえずサンプルを。 もしかしたら、ＶＢＡではなく、手作業で処理する上での質問かもしれないので、的外れかもしれないし 処理時間も、ぜんぜん短くならないじゃないか！！としかられるかもしれないけど。 （膨大な行数のデータを相手に、ループの中で文字列連結しているところが自分でも気になるし）
以下を貼り付けたら、ダミーで以下も行って。 ・ユーザーフォームを挿入 ・その後、ユーザーフォームをエキスポートなしで解放。 （DataObjectを使うためのモジュールを参照設定するため）
Option Explicit
Sub Test()
'Microsoft Forms x.x Object Library 参照設定(DataObject用)
Dim myPath As String
Dim Fso As Object
Dim myT As Object
Dim Dobj As DataObject
Dim s As String
Set Fso = CreateObject("Scripting.FileSystemObject")
'フォルダとファイル名は適切なものに。
myPath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\CSVフォルダ"
Set myT = Fso.OpenTextFile(myPath & "\CSVTEST.csv")
With myT
Do While .AtEndOfStream = False
s = s & Replace(.ReadLine, ",", vbTab) & vbCrLf
Loop
End With
Set Dobj = New DataObject
Dobj.SetText s
Dobj.PutInClipboard
Worksheets.Add.Paste
Set myT = Nothing
Set Fso = Nothing
Set Dobj = Nothing
End Sub
さすがにデータ量が多いので、各段に早くはなりませんね。 拙いコードですが、こんなのもどうでしょうか？ フィルターも配列上でやってしまえます。
Sub Test() Dim n As Integer Dim buf() As Byte Dim myFileName As Variant Dim tbl As Variant
myFileName = Application.GetOpenFilename()
If VarType(myFileName) = vbBoolean Then
MsgBox "キャンセル"
Else
n = FreeFile
Open myFileName For Binary As n
ReDim buf(1 To LOF(n))
Get #n, , buf
Close n
tbl = Split(StrConv(buf, vbUnicode), vbCrLf)
'#### フィルターを掛けるなら以下1行を追加
'tbl = CsvFilter(tbl, 14, "1")
'#### ここまで
tbl = Application.WorksheetFunction.Transpose(tbl)
Application.ScreenUpdating = False
With Worksheets.Add.Range("A1").Resize(UBound(tbl))
.CurrentRegion.ClearContents
.Value = tbl
.TextToColumns .Cells(1), xlDelimited, xlDoubleQuote, False, False, False, True, False, False
End With
Application.ScreenUpdating = True
End If
End Sub
Private Function CsvFilter(myList As Variant, myField As Long, myStr As String)
Dim i As Long
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "([^,]+)"
For i = 0 To UBound(myList)
With .Execute(myList(i))
If .Count > 0 Then
If .Item(myField - 1).Value = myStr Then
myList(i) = vbNullChar
End If
End If
End With
Next i
End With
CsvFilter = Filter(myList, vbNullChar, False)
End Function
（ｍｏｍｏ）
ぶらっとさん、ｍｏｍｏさんありがとうございます。 こんなに難しいコードになるとは思ってもみませんでした。申し訳ありませんでした。
csvファイルの件 ネットワークを通じて所定場所に保管し、ネットワーク先でcsvファイル を開き、デスクトップにあるファイルに貼り付けるときに33秒かかります。
行削除の件 フィルターにより、行削除する項目が4項目あるので、行削除ではなく残す分を 別シートに移すことを考えるようにします。 (あちゃこ)
>ネットワークを通じて所定場所に保管し、ネットワーク先でcsvファイル >を開き、デスクトップにあるファイルに貼り付けるときに33秒かかります。
離れた場所にあるファイルはアプリケーションで開かず、ファイルコピーでローカルサイドに もってきてから開くと、少しは早くなるんじゃないかなぁ。 (処理後、ローカルのファイルは削除。)
(ぶらっと)
CSVファイルから条件にあったデータ行を取り出す方法ならありますよ！！
とりあえず、簡単なサンプルデータを作成することからやりましょう。
新規ブックの標準モジュール（Module1）に
以下のコード
'====================================================================
Option Explicit
Sub mk_csv_file()
Dim flno As Long
Dim dat As String
Dim g0 As Long
Randomize Date
flno = FreeFile
Open ThisWorkbook.path & "\file.csv" For Output As #flno
dat = mk_header(95)
Print #flno, dat
For g0 = 1 To 50000
dat = mk_data(95)
Print #flno, dat
Next
Close #flno
End Sub
'===========================================================
Function mk_header(num As Long) As Variant
Dim g0 As Long
ReDim myarray(1 To num)
For g0 = LBound(myarray) To UBound(myarray)
myarray(g0) = "項目" & g0
Next
mk_header = Join(myarray, ",")
End Function
'==================================================
Function mk_data(num As Long) As Variant
Dim g0 As Long
ReDim myarray(1 To num)
For g0 = LBound(myarray) To UBound(myarray)
myarray(g0) = Int(Rnd * 1000) + 1
Next
mk_data = Join(myarray, ",")
End Function
私の環境で20秒ほどで作成されます。
項目1,項目2,項目3,･･････項目95 123,15,5,・・・・・123 ・ ・
これで5万件、95列のCSVファイルが作成されるはずです。
数字は、乱数で作成しているので上記と同じではありませんが、1～1000までの 整数です。
同ブックの別の標準モジュール（Module2）にAdoでテキスト操作関連プロシジャー群 忘れるほど前に作っておいたやつ つい最近別サイトで久しぶりに使いました。
Option Explicit
'=============================================================
Private cn As Object
'=============================================================
Function open_ado_text(path As String) As Long 'adoでテキストにアクセス
On Error Resume Next
Dim link_opt As String
Set cn = CreateObject("adodb.connection")
link_opt = "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"DBQ=" & path & ";" & "ReadOnly=0"
cn.Open link_opt
open_ado_text = Err.Number
On Error GoTo 0
End Function
'=============================================================
Sub close_ado() 'クローズ
On Error Resume Next
cn.Close
On Error GoTo 0
End Sub
'=============================================================
Function exec_sql(sql_str, rs As Object) As Long 'Sqlの実行
On Error Resume Next
Set rs = cn.Execute(sql_str)
exec_sql = Err.Number
If Err.Number <> 0 Then MsgBox Err.Description
On Error GoTo 0
End Function
'==========================================================================
Function mk_schema_ini(path As String, dat() As String) As Long
'schema.iniの作成
On Error GoTo err_mk_schema_ini
Dim fno As Long
Dim didx As Long
mk_schema_ini = 0
fno = FreeFile()
Open path & "\schema.ini" For Output As #fno
For didx = LBound(dat()) To UBound(dat())
Print #fno, dat(didx)
Next
Close #fno
ret_mk_schema_ini:
On Error GoTo 0
Exit Function
err_mk_schema_ini:
MsgBox Err.Description
mk_schema_ini = Err.Number
Resume ret_mk_schema_ini
End Function
'=============================================================
Function del_schema_ini(path As String) 'schema_iniの削除
On Error Resume Next
Kill path & "\schema.ini"
On Error GoTo 0
End Function
別の標準モジュール（Module3）にCSV検索プロシジャー
'===============================================================
Option Explicit
Sub main()
Dim ret As Long
Dim g0 As Long
Dim dat(1 To 99) As String
Dim rs As Object
Dim ans As Variant
Columns("a:cm").Clear
dat(1) = "[file.csv]"
dat(2) = "ColNameHeader = true"
dat(3) = "CharacterSet = oem"
dat(4) = "Format = CSVDelimited"
For g0 = 5 To 95
dat(g0) = "Col" & (g0 - 4) & "=項目" & (g0 - 4) & " LONG"
Next
Call mk_schema_ini(ThisWorkbook.path, dat())
ret = open_ado_text(ThisWorkbook.path)
If ret = 0 Then
ret = exec_sql("select top 1 * from file.csv where [項目4]=1;", rs)
If ret = 0 Then
With ActiveSheet
With .Range("a1:cm1")
.Formula = "=""項目""&column()"
.Value = .Value
End With
.Range("a2").CopyFromRecordset rs
End With
rs.Close
Else
MsgBox Error(ret)
End If
close_ado
End If
Call del_schema_ini(ThisWorkbook.path)
Erase dat()
End Sub
このmainというプログラムの実行で、項目4が 1であるデータの最初の行を取り出しています。
5万件もあるなら、こんなデータベース的な処理も考慮に入れてみてください。
ichinose
サンプルデータ作成のModule1でコンパイルエラーが出てしまいます。 dat = mk_header(95)で止まってしまいます。 なぜでしょうか？ （あちゃこ）
>dat = mk_header(95)で止まってしまいます。 あらっ、これは想定外でした。他にどんなメッセージですか？ 「Subまたは、Functionが定義されていません」ですか？ だとしたら、
Function mk_header(num As Long) As Variant ↑この行以下も同じModule内に記述してください
他の内容なら、それを教えて下さい
ichinose
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.