[[20090626220158]] 『VBAでCSVを可変で取り込むには』(ひでー) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBAでCSVを可変で取り込むには』(ひでー)
現在、D:\前準備のフォルダ内にcsvファイルが入っており、それをVBAで”前準備.xls”のシートに読み込んでいますが ”_りんご.csv”や”_巨峰.csv”が固定で、 ”2010_1_@高砂屋” の部分が毎回変わってD:\前準備のフォルダ内に入る場合(古いデータは消去し毎度新しい2ファイルしか入ってません)でも下記のVBAを駆動させるにはどうしたらよいのでしょうか?まだVBAをかじりたてでよい案が浮かびません m(_ _)m

Sub 前準備()
'

    Windows("前準備.xls").Activate
    Sheets("りんご").Select
    On Error GoTo Err1
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\前準備\2010_1_@高砂屋_りんご.csv", Destination:=Range("A1"))
        .Name = "2010_1_@高砂屋_りんご"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry1:

Sheets("巨峰").Select

    On Error GoTo Err2
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\前準備\2010_1_@高砂屋_巨峰.csv", Destination:=Range("A1"))
        .Name = "2010_1_@高砂屋_巨峰"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry2:

Exit Sub
Err1:

    Resume Retry1
Err2:
    Resume Retry2
end sub

[エクセルのバージョン]
Excel2003
[OSのバージョン]
WindowsXP


 > D:\前準備のフォルダ内にcsvファイルが入っており、
 > (古いデータは消去し毎度新しい2ファイルしか入ってません)

   D:\前準備
      --- *_りんご.csv
      --- *_巨峰.csv

 > "前準備.xls”のシートに読み込んでいます

 2つのCSVファイルをシートにインポートしているということでしょうか?
 それでしたら、シート名とファイル名以外は 2つの処理は同じなのだから、
 サブプロシージャに独立させて、Main側から シート名を指定して2回呼び出せば
 よさそうです。
  (kanabun)  

 Sub 前準備xlsにCSVインポート() '
    Dim myPath As String
    myPath = "D:\前準備\"

    ChDrive myPath
    ChDir myPath
    If Right$(myPath, 1) <> "\" Then myPath = myPath & "\"

    CSVのインポート "りんご"

    CSVのインポート "巨峰"

 End Sub

 Private Sub CSVのインポート(mySheet As String)
    Dim myCSV As String
    Dim qName As String
    Dim WS As Worksheet

    myCSV = Dir("*_" & mySheet & ".csv")
    If Len(myCSV) = 0 Then
        MsgBox mySheet & " CSVファイルが見つかりませんでした"
        Exit Sub
    End If
    qName = Dir(myCSV)
    qName = Left$(qName, Len(qName) - 4)

    On Error Resume Next
    Set WS = ActiveWorkbook.Worksheets(mySheet)
    On Error GoTo 0
    If WS Is Nothing Then
        MsgBox "シート「" & mySheet & "」がありません"
        Exit Sub
    End If
    With WS.QueryTables.Add(Connection:= _
        "TEXT;" & myCSV, Destination:=WS.Range("A1"))
        .Name = qName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1) '列のデータ型が文字列なら 2 にしたほうがよい
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        .Delete  '接続の切断  追加
    End With
 End Sub


 以下の行は ゴミでした。
 コメントアウトしておいてください。

 >   If Right$(myPath, 1) <> "\" Then myPath = myPath & "\"

  (kanabun) 

(kanabun) さん早速のレスありがとうございます。

追伸のあった部分はコメントアウトしVBAを起動させたのですが、
”りんごcsvファイルが見つかりませんでした””巨峰csvファイルが見つかりませんでした”とメッセージボックスが出たあと
何もインポートされません。

一応"2"にもしてみましたが同様でした。

D:\前準備のフォルダ内には 2010_1_@高砂屋_りんご.csv と 2010_1_@高砂屋_巨峰.csv が入っています。

部分部分勉強不足の為、理解が追いつかない所がありますが、教えていただいたVBAは
"*_りんご.csv"と"*_巨峰.csv"のファイルが D:\前準備のフォルダに入っていれば、
"前準備.xls”のシートにインポート(シートは、りんご・巨峰の名前で作っています)されるプログラムですか?


 > 教えていただいたVBAは "*_りんご.csv"と"*_巨峰.csv"のファイルが
 > D:\前準備のフォルダに入っていれば、
 > "前準備.xls”のシートにインポート(シートは、りんご・巨峰の名前で作っています)されるプログラムですか? 

 はい。いちおうそのつもりだったんですが、コードをご覧になって分かるように
コードには "前準備.xls" というBook名はどこにも登場してません。
代わりに、
     Set WS = ActiveWorkbook.Worksheets(mySheet)
と、ActiveWorkbookという表現で、アクティブなBook内の「りんご」シートや「巨峰」シート
を参照するようになっています。
 とりあえず、「りんご」「巨峰」シートの入っている『前準備.xls』をアクティブにして
検証してください。

 でも、エラーはそこで起きているのでなく、その前の

 >   myCSV = Dir("*_" & mySheet & ".csv")
 >   If Len(myCSV) = 0 Then
 >       MsgBox mySheet & " CSVファイルが見つかりませんでした"
 >       Exit Sub
 >   End If
 の部分なんですよね?
 こちらでも "D:\前準備" フォルダのなかに 
 「2010_1_りんご.csv」と「2010_2_巨峰.csv」をおいてテストしてみましたが
 ちゃんとインポートできました。
 どこかフォルダ構成とか が違っているということはないですか?

 または
 >   myCSV = Dir("*_" & mySheet & ".csv")
 の部分を
     myCSV = Dir("*" & mySheet & "*.csv")
 と変更して(ワイルドカードを少しあいまいにして) *りんご*.csv などでファイルを拾ってみる
 とか?

  (kanabun)


(kanabun)すみません。できるだけシンプルにと思い2ファイルでの質問をしましたが、実際はCSVファイルが8ファイルなのと
その格納場所が D:\共有\ナンバリング\本場所\東京場所\アクセス前準備 です。

ファイル名は 2010_1_@高砂屋_1_マスA.csv

         2010_1_@高砂屋_2_マスB.csv

         2010_1_@高砂屋_3_マスC.csv

         2010_1_@高砂屋_4_特別限定.csv

         2010_1_@高砂屋_5_身障者.csv

         2010_1_@高砂屋_6_ボックス.csv

         2010_1_@高砂屋_7_溜.csv

         2010_1_@高砂屋_8_維持員.csv

で D:\共有\ナンバリング\本場所\東京場所\アクセス前準備.xls の中のシート分けをマスA・マスB・マスC・特別限定・身障者・ボックス・溜維持員と

し、そのアクセス前準備.xls内で下記のマクロを使っていますが、今後新しいデータに変更した場合でもマクロを利用できるようにしたいです。

たとえば新しいファイルを格納場所に入れたときの名前は

         2010_1_A紀の国家_1_マスA.csv

         2010_1_A紀の国家_2_マスB.csv

         2010_1_A紀の国家_3_マスC.csv

         2010_1_A紀の国家_4_特別限定.csv

         2010_1_A紀の国家_5_身障者.csv

         2010_1_A紀の国家_6_ボックス.csv

         2010_1_A紀の国家_7_溜.csv

         2010_1_A紀の国家_8_維持員.csv

_マスA.csv など末尾の情報を検知してインポートが可能となるVBAを質問させていただきました。
(kanabun)に考えてもらったVBAで、自分なりに考えて変更した所は

myPath = "D:\前準備\"    ⇒   myPath = "D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\"

CSVのインポート "りんご"    ⇒   CSVのインポート "マスA"

CSVのインポート "巨峰"    ⇒   CSVのインポート "マスB"

追加で                    CSVのインポート "マスC"

                           CSVのインポート "特別限定"

                           CSVのインポート "身障者"

                           CSVのインポート "ボックス"

                           CSVのインポート "溜"

                           CSVのインポート "維持員"

を変更しただけでは駄目なんでしょうか?
ご指摘の通り、りんご・巨峰での質問通りでは問題なく動いておりました。すみません。

下記がいままで実際しようしていたマクロです。いままでは アクセス前準備.xls を開きマクロを実行していました。
(kanabun)が言っていたアクティブはエクセルファイルを開けばアクティブ状態ですよね。
今回の条件で実行させるには他に手を加える所があるのでしょうか?
お手数かけますがよろしくおねがいします。

Sub Access前準備()
'
' Access前準備 Macro
' マクロ記録日 : 2009/6/23 ユーザー名 :
'

'

    Windows("Access前準備.xls").Activate
    Sheets("マスA").Select
    On Error GoTo Err1
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_1_マスA.csv", Destination:=Range("A1"))
        .Name = "マスA"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry1:
    Sheets("マスB").Select
    On Error GoTo Err2
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_2_マスB.csv", Destination:=Range("A1"))
        .Name = "マスB"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry2:
    Sheets("マスC").Select
    On Error GoTo Err3
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_3_マスC.csv", Destination:=Range("A1"))
        .Name = "マスC"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry3:
    Sheets("特別限定").Select
    On Error GoTo Err4
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_4_特別限定.csv", Destination:=Range("A1"))
        .Name = "特別限定"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry4:
    Sheets("身障者").Select
    On Error GoTo Err5
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_5_身障者.csv", Destination:=Range("A1"))
        .Name = "身障者"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry5:
    Sheets("ボックス").Select
    On Error GoTo Err6
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_5_ボックス.csv", Destination:=Range("A1"))
        .Name = "ボックス"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry6:
    Sheets("溜").Select
    On Error GoTo Err7
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_7_溜.csv", Destination:=Range("A1"))
        .Name = "溜"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry7:
    Sheets("維持員").Select
    On Error GoTo Err8
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\2010_1_@高砂屋_8_維持員.csv", Destination:=Range("A1"))
        .Name = "維持員"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Retry8:

    Sheets("マスA").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("マスB").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("マスC").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("特別限定").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("身障者").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("ボックス").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("溜").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("維持員").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "データ"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "方向"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "日付"
    Range("A1").Select

    Sheets("マスA").Select
    Range("A1").Select

    'ActiveWorkbook.Save
    'ActiveWindow.Close

    Exit Sub
Err1:
    Resume Retry1
Err2:
    Resume Retry2
Err3:
    Resume Retry3
Err4:
    Resume Retry4
Err5:
    Resume Retry5
Err6:
    Resume Retry6
Err7:
    Resume Retry7
Err8:
    Resume Retry8

End Sub


 こんにちは。

 > 実際はCSVファイルが8ファイルなのと
 > その格納場所が D:\共有\ナンバリング\本場所\東京場所\アクセス前準備 です。 
 >
 > で 
 > D:\共有\ナンバリング\本場所\東京場所\アクセス前準備.xls
 > の中のシート分けを
 >   マスA・マスB・マスC・特別限定・身障者・ボックス・溜・維持員とし、
 >  そのアクセス前準備.xls内で下記のマクロを使っていますが、

 >   自分なりに考えて変更した所は 
 >
 >   myPath = "D:\前準備\"    ⇒ myPath = "D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\" 
 >   
 >   CSVのインポート "りんご"     ⇒ CSVのインポート "マスA" 
 >   CSVのインポート "巨峰"       ⇒ CSVのインポート "マスB" 
 > 追加で
 >                          CSVのインポート "マスC" 
 >                          CSVのインポート "特別限定"
 >                          CSVのインポート "身障者"
 >                          CSVのインポート "ボックス"
 >                          CSVのインポート "溜"
 >                          CSVのインポート "維持員"
 >を変更しただけでは駄目なんでしょうか?
 >ご指摘の通り、りんご・巨峰での質問通りでは問題なく動いておりました。
 >すみません。 

 基本的にその変更・追加で問題ないと思いますよ。

 あと
 >  今後新しいデータに変更した場合でもマクロを利用できるようにしたいです。 
 ということなので、変更時には
 呼び出し側のプログラム内のシート名のリストを変えるだけで、あとは変更なしで
 作業できるようにしておくといいですよ。

 作業手順としては
 (1)D:\共有\ナンバリング\本場所\東京場所\アクセス前準備.xls
    を開いておく。
 (2)↓のマクロ内の転記シート名リストを必要に応じて 変更する。
 (3) 『アクセス前準備.xls』をアクティブにして↓を実行する。

 Sub CSV転記プログラム() '<---- このマクロを実行する
    Dim myPath As String
    Dim Sheetnames, Sheetname           

    ' CSVファイルのあるフォルダは アクティブなBook (たとえば 『アクセス前準備.xls』)と同じフォルダとする
    myPath = ActiveWorkbook.Path

    '転記先シート名のリスト(カンマ区切りで書き込む)
    Sheetnames = Split("マスA,マスB,マスC,特別限定,身障者,ボックス,溜,維持員", ",")

    ChDrive myPath
    ChDir myPath

    For Each Sheetname In Sheetnames
        CSVのインポート CStr(Sheetname)
    Next

 End Sub

  (kanabun) 2009-06-27 14:20頃


(kanabun)何度もすみません。下記の8ファイルを
格納場所が D:\共有\ナンバリング\本場所\東京場所\アクセス前準備 へ入れた状態で、
アクセス前準備.xlsを開き、下のマクロを実行したとき
 ”マスA、マスB、マスC csvファイルが見つかりませんでした”と3回メッセージボックスが表示され
インポートされません。その後の特別限定・身障者・ボックス・溜・維持員はインポートされております。
何が原因でしょうか?

ファイル名は 2010_1_@高砂屋_1_マスA.csv

         2010_1_@高砂屋_2_マスB.csv

         2010_1_@高砂屋_3_マスC.csv

         2010_1_@高砂屋_4_特別限定.csv

         2010_1_@高砂屋_5_身障者.csv

         2010_1_@高砂屋_6_ボックス.csv

         2010_1_@高砂屋_7_溜.csv

         2010_1_@高砂屋_8_維持員.csv

Sub アクセス前準備xlsにCSVインポート() '

    Dim myPath As String
    myPath = "D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\"
    ChDrive myPath
    ChDir myPath
    'If Right$(myPath, 1) <> "\" Then myPath = myPath & "\"

    CSVのインポート "マスA"
    CSVのインポート "マスB"
    CSVのインポート "マスC"
    CSVのインポート "特別限定"
    CSVのインポート "身障者"
    CSVのインポート "ボックス"
    CSVのインポート "溜"
    CSVのインポート "維持員"

 End Sub

 Private Sub CSVのインポート(mySheet As String)
    Dim myCSV As String
    Dim qName As String
    Dim WS As Worksheet
    myCSV = Dir("*_" & mySheet & ".csv")
    If Len(myCSV) = 0 Then
        MsgBox mySheet & " CSVファイルが見つかりませんでした"
        Exit Sub
    End If
    qName = Dir(myCSV)
    qName = Left$(qName, Len(qName) - 4)
    On Error Resume Next
    Set WS = ActiveWorkbook.Worksheets(mySheet)
    On Error GoTo 0
    If WS Is Nothing Then
        MsgBox "シート「" & mySheet & "」がありません"
        Exit Sub
    End If
    With WS.QueryTables.Add(Connection:= _
        "TEXT;" & myCSV, Destination:=WS.Range("A1"))
        .Name = qName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 2, 1) '列のデータ型が文字列なら 2 にしたほうがよい
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        .Delete  '接続の切断  追加
    End With
 End Sub


 横から失礼しますが、A、B、Cの半角全角は一致していますか?
 ファイル名から直接コピー&ペーストして動かしてみてはどうでしょうか。
 (Mook)

(Mook)コメントありがとうございます。
自分も念の為、CSVのインポート "" の項目をもう一度、
実際の格納場所 D:\共有\ナンバリング\本場所\東京場所\アクセス前準備内のファイル名で
直接コピー&ペーストして動かしてみましたが、何故か
 ”マスA、マスB、マスC”csvファイルが見つからずインポートできませんでした。

 > と3回メッセージボックスが表示されインポートされません。
 > その後の特別限定・身障者・ボックス・溜・維持員はインポートされております。
 > 何が原因でしょうか? 

 > ファイル名は 2010_1_@高砂屋_1_マスA.csv 
 >       2010_1_@高砂屋_2_マスB.csv 
 >       2010_1_@高砂屋_3_マスC.csv 

 Sub アクセス前準備xlsにCSVインポート() ' 

    Dim myPath As String
    myPath = "D:\共有\ナンバリング\本場所\東京場所\アクセス前準備\"
    ChDrive myPath
    ChDir myPath

    CSVのインポート "マスA"
    CSVのインポート "マスB"
    CSVのインポート "マスC"
    CSVのインポート "特別限定"
    CSVのインポート "身障者"
    CSVのインポート "ボックス"
    CSVのインポート "溜"
    CSVのインポート "維持員"

 End Sub

 Mookさんのアドバイスのとおり、シート名が全角でファイル名が半角 ってことではないですか?
 現に、シート名"マスA" で、
      ファイル名 _マスA.csv 
 となってますし。。。

 以下のように、変更してみてはどうでしょう?

 Private Sub CSVのインポート(mySheet As String)
    Dim myCSV As String
    Dim qName As String
    Dim WS As Worksheet
    myCSV = Dir("*_" & StrConv(mySheet,vbWide) & ".csv")
    If Len(myCSV) = 0 Then
        myCSV = Dir("*_" & StrConv(mySheet,vbNarrow) & ".csv")
        If Len(myCSV) = 0 Then
            MsgBox mySheet & " CSVファイルが見つかりませんでした"
            Exit Sub
        End If
    End If
    qName = Left$(myCSV, Len(myCSV) - 4)
    On Error Resume Next
    Set WS = ActiveWorkbook.Worksheets(mySheet)
    On Error GoTo 0
    '以下 省略


ご指摘の通りファイル名とマクロの中は同じものでしたが、シート名が半角全角が違いました。
無事に動くようになりました。ありがとうございました。

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.