[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Dir関数が上手くうごきません』（いち）
エクセルのsheetのA6から、選択したフォルダ内にあるCSVファイルのデータ内容をを貼り付けたいです。
空行から追加貼り付けしたいです。
※CSVファイルは精度が低い為、modGetCSVRecで、配列にデータをいれてsheetにCSVデータを貼り付けてます。
現状以下のソースの①の部分でデバックが発生します。デバックをとめると、フォルダ内の1つ目のCSVファイルのみを貼り付けます。
ソースを追って、①の部分をwithの中にいれましたが、デバック発生しました。
ご教授お願いいたします。
以下がデバックが起こっているソースです。
'*******************************************************************************
' CSV形式ファイル読み込み処理(カンマ数不定処理)
'*******************************************************************************
Option Explicit
Const cnsTITLE = "テキストファイル読み込み処理"
Const cnsFILTER = "全てのファイル (*.*),*.*"
Const cnsStartRow = 1
'Private Const ROW_STA_DATA As Integer = 6 '行
'Private Const ROW_STA_DATA As Long = 6 '行
Private Const ROW_STA_DATA As Long = 65536 '最終行
'*******************************************************************************
Sub CSVImport_Click()
Dim MyObj As Object
Dim MyFol As String
Dim MyFnm As String
Dim MyStr As String
Dim i As Long
Dim intFF As Integer ' FreeFile値
Dim IX1 As Long ' CSV項目ｶﾗﾑINDEX
Dim GYO As Long ' 収容するｾﾙの行
Dim lngREC As Long ' ﾚｺｰﾄﾞ件数ｶｳﾝﾀ
Dim vntREC As Variant ' ﾚｺｰﾄﾞ内容(配列)
Dim strDummy As String ' 読み飛ばし用ダミー
Dim nNextRow As Long '次に貼り付ける行
'フォルダを選択する
Set MyObj = CreateObject("Shell.Application") _
.BrowseForFolder(0, "SelectFolder", 0)
'選択なければ処理を抜ける
If MyObj Is Nothing Then Exit Sub
MyFol = MyObj.self.Path & "\"
MsgBox MyFol & "を処理します。"
Set MyObj = Nothing
Application.ScreenUpdating = False
MyFnm = Dir(MyFol & "*.csv") ①
'シート名管理表 (2012)にて処理
With Sheets("管理表 (2012)")
'開始行を貼り付ける
nNextRow = Range("A" & ROW_STA_DATA).End(xlUp).Row + 1
'Dir関数を使って指定フォルダ内csvファイルを順次処理
Do Until Len(MyFnm) = 0&
i = i + 1
'データエリアを取得してセット先を変更
' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ﾌｧｲﾙをOPEN(入力ﾓｰﾄﾞ)
Open MyFnm For Input As #intFF
' 先頭行読み飛ばし
If Not EOF(intFF) Then
Line Input #intFF, strDummy
End If
' ﾌｧｲﾙのEOF(End of File)まで繰り返す
Do While Not EOF(intFF)
' ﾚｺｰﾄﾞ件数ｶｳﾝﾀの加算
lngREC = lngREC + 1
' 行単位にﾚｺｰﾄﾞを読み込む(共通処理)
vntREC = modGetCSVRec.FP_GET_CSV_REC(intFF)
IX1 = UBound(vntREC) + 1
' 行を加算しﾚｺｰﾄﾞ内容を表示(先頭は2行目)
Range(Cells(nNextRow, 1), Cells(nNextRow, IX1)).Value = vntREC ' 配列渡し
nNextRow = nNextRow + 1
Loop
Close #1
MsgBox "最終行は：" & nNextRow
'次のファイルへ
MyFnm = Dir()
Loop
End With
If i > 0 Then
MyStr = i & "個のファイルを処理しました。"
Else
'検索結果が０なら
MyStr = "検索条件を満たすファイルはありません。"
End If
Application.ScreenUpdating = True
MsgBox MyStr
End Sub
以下がmodGetCSVRecになります。
'*******************************************************************************
' CSV形式ファイル読み込み処理(カンマ数不定処理) '*******************************************************************************
Option Explicit
Const cnsDQ = """"
Const cnsDQCM = ""","
Const cnsCOM = ","
Const cnsBLNK = ""
Const cnsPROD = "."
'*******************************************************************************
' CSV形式の1ﾚｺｰﾄﾞの受け取り ※現時点ではｴﾗｰ処理なし
' (引数はﾌｧｲﾙ№,戻り値はCSVﾚｺｰﾄﾞ内容の配列)
'*******************************************************************************
Public Function FP_GET_CSV_REC(intFF As Integer) As Variant
Dim strREC As String ' ﾚｺｰﾄﾞ内容(連結後)
Dim strREC2 As String ' ﾚｺｰﾄﾞ内容(連結前)
Dim strTEXT As String ' 1項目の内容
Dim strTEXT2 As String ' Work
Dim POS As Long ' 項目先頭ｶﾗﾑ
Dim POS2 As Long ' 項目間のｶﾝﾏ位置
Dim X() As Variant ' ﾚｺｰﾄﾞ内容WORK
Dim IX As Long ' 項目INDEX
Dim lngLEN As Long ' ﾚｺｰﾄﾞ長
Dim swTRUE As Boolean ' ﾚｺｰﾄﾞ連結判断ｽｲｯﾁ
Dim swDQ As Byte ' ﾀﾞﾌﾞﾙｸｫｰﾃｰｼｮﾝｽｲｯﾁ
Dim lngERR As Long ' エラーコード
Dim dteDate As Date ' 日付試験用Work
strREC = ""
' 項目途中改行対応のため､行末判定は独自に行なう
Do Until swTRUE = True
swTRUE = True
' ﾚｺｰﾄﾞの読込み
Line Input #intFF, strREC2
' 分断ﾚｺｰﾄﾞ対応のため文字列を接合する
strREC = strREC & strREC2
lngLEN = Len(strREC)
' 配列を初期化
IX = -1
ReDim X(0)
' ﾚｺｰﾄﾞ内容を1文字ずつ判定する
POS = 1
Do While POS <= lngLEN
POS2 = POS + 1
swDQ = 0
If Mid$(strREC, POS, 1) = cnsDQ Then
swDQ = 1
' 先頭がﾀﾞﾌﾞﾙｸｫｰﾃｰｼｮﾝの場合､項目末のﾀﾞﾌﾞﾙｸｫｰﾃｰｼｮﾝを探す
Do While POS2 < lngLEN
If Mid$(strREC, POS2, 2) = cnsDQCM Then Exit Do
POS2 = POS2 + 1
Loop
If POS2 >= lngLEN Then
' 行末に達した場合は正しい文字列か判定する
If Right$(strREC, 1) = cnsDQ Then
strTEXT = Trim$(Mid$(strREC, POS + 1, lngLEN - POS - 1))
Else
' 不揃いの場合は次ﾚｺｰﾄﾞを読み込むように指示する
strTEXT = cnsBLNK
swTRUE = False
End If
ElseIf POS2 > (POS + 1) Then
' 両端のﾀﾞﾌﾞﾙｸｫｰﾃｰｼｮﾝを外す
strTEXT = Trim$(Mid$(strREC, POS + 1, POS2 - POS - 1))
Else
strTEXT = cnsBLNK
End If
POS2 = POS2 + 1
ElseIf Mid$(strREC, POS, 1) = cnsCOM Then
' ｶﾝﾏのみの場合はEmptyをｾｯﾄさせる
strTEXT = ""
POS2 = POS2 - 1
Else
' 先頭がﾀﾞﾌﾞﾙｸｫｰﾃｰｼｮﾝでない場合は単純にｶﾝﾏを探す
Do While POS2 <= lngLEN
If Mid$(strREC, POS2, 1) = cnsCOM Then Exit Do
POS2 = POS2 + 1
Loop
If POS2 > POS Then
strTEXT = Trim$(Mid$(strREC, POS, POS2 - POS))
Else
strTEXT = cnsBLNK
End If
End If
' ﾃｰﾌﾞﾙ要素数を追加して内容をｾｯﾄ
IX = IX + 1
ReDim Preserve X(IX)
strTEXT2 = StrConv(strTEXT, vbUpperCase)
If ((IsNumeric(strTEXT) = True) And (swDQ <> 1)) Then
' 数値でﾀﾞﾌﾞﾙｸｫｰﾃｰｼｮﾝで囲われていない
If InStr(1, strTEXT, cnsPROD, vbTextCompare) <> 0 Then
X(IX) = CDbl(strTEXT) ' 実数は浮動小数点型
Else
X(IX) = CCur(strTEXT) ' 整数は通貨型
End If
ElseIf IsDate(strTEXT) Then
X(IX) = CDate(strTEXT) ' 日付型
On Error Resume Next
dteDate = X(IX)
lngERR = Err.Number
On Error GoTo 0
If lngERR <> 0 Then
' 日付エラー!
X(IX) = strTEXT ' 文字列型に変更
ElseIf dteDate < #1/1/1900# Then
' 日付範囲外
X(IX) = strTEXT ' 文字列型に変更
Else
X(IX) = dteDate
End If
ElseIf ((strTEXT2 = "TRUE") Or (strTEXT2 = "FALSE")) Then
X(IX) = CBool(strTEXT) ' Boolean型
ElseIf strTEXT <> cnsBLNK Then
X(IX) = strTEXT ' 文字列型
Else
' ﾌﾞﾗﾝｸの場合は初期化(Empty)
X(IX) = Empty
End If
POS = POS2 + 1
Loop
' EOFの場合は無条件に終了とする
If EOF(intFF) = True Then swTRUE = True
Loop
' 配列を戻り値にｾｯﾄ
FP_GET_CSV_REC = X
End Function
'-----------------------------<< End of Source >>-------------------------------
なんというエラーが発生するかも書いたほうがいいよ。 (春日野馨)
春日野馨さんと衝突。
コードを読む元気がないので、まだ目を通していないけど、エラー発生時のメッセージを教えてくれる？
＊「デバッグが発生する」という表現はないんだけど、テーマとは関係ないし、 ざらっと目に入ったコードの最初に、Const と Private Const があるところも、なんだかなぁ・・とは思うけど これも、テーマとは関係ないので、ただの「つぶやき」としてスルーして。
(ぶらっと)
エラーて、
MyFnm = Dir(MyFol & "*.csv") ①
て、此処では無く
' 指定ﾌｧｲﾙをOPEN(入力ﾓｰﾄﾞ)
Open MyFnm For Input As #intFF
此処で起きているのでは？ Dirは確か、ファイル名だけを返すのでPathが無いのでは？
' 指定ﾌｧｲﾙをOPEN(入力ﾓｰﾄﾞ)
Open MyFol & MyFnm For Input As #intFF
とすれば善いかも？
(Bun)
' 指定ﾌｧｲﾙをOPEN(入力ﾓｰﾄﾞ) Open MyFol & MyFnm For Input As #intFF このコードに変えたら動きました！！
ありがとうございました！！
春日野馨さん、ぶらっとさん
ご指摘ありがとうございます。
以下のメッセージがでます。
eroer 53
this files not fined
(いち)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.