Excel VBでのデータの取り込み方

質問

Excel　VBを使って、デスクトップにあるcsv形式のデータを取り込むマクロを作りました（「マクロの記録」にて）。データは10個あるので、同じようなマクロを10個作っています。

そこで、取り込むcsvのファイル名ですが、01.csv、02.csv、…、10.csvという名前になるように1つ1つ名前の変更をしてから取り込んでいます。
これをもとのファイル名のままで、番号の若いもの順から取り込むということは出来ないでしょうか。

元のファイル名は「1002.csv」「1234.csv」「3456.csv」などと「（4ケタの数字）.csv」です。

今、使っているVBは以下の通りです（長くてすみません）。

どうぞよろしくお願いいたします。
------------------------------------------------------------------------
Sub data01取り込み()
'
' data01取り込み Macro
'

'
Sheets("data1").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\user\Desktop\データ\01.csv", Destination:=Range("$A$1"))
.Name = "cell1"
.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 = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Range("E2:E400").Select
Selection.Copy
Sheets("計算").Select
ActiveWindow.SmallScroll Down:=-16
Range("e4").Select
ActiveSheet.Paste
End Sub
----------------------------------------------------------------

回答No.5

NotFound404 · ベストアンサー

失礼しました。
途中までですが以下でどうでしょう？
メニューの挿入から標準モジュールに張り付けてお試しください。
data1 ～data10 のシートがすでにある前提です。

Sub 取り込みメイン()
Dim FileList() As Variant, tmpName As Variant
Dim i As Integer

With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = Environ("userProfile") & "\desktop"
.Filters.Clear
.Filters.Add "CSVファイル", "*.csv"
.Filters.Add "すべてのファイル", "*.*"
.FilterIndex = 1

If CBool(.Show) Then
'選択ファイルのパスの格納
ReDim Preserve FileList(.SelectedItems.Count - 1)
For Each tmpName In .SelectedItems
FileList(i) = tmpName
i = i + 1
Next
Else
MsgBox "選択ファイルが無いので中止しました"
Exit Sub
End If
End With

For i = LBound(FileList) To UBound(FileList)
'Debug.Print FileList(i), i
Call 取り込みSheet(FileList(i), i + 1)
Next
End Sub

Private Sub 取り込みSheet(ByVal MyFileName As String, ByVal MyFileNo As Integer)
Worksheets("data" & CStr(MyFileNo)).Select
Cells.Delete '必要に応じて不要かも
Range("A1").Select

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & MyFileName, Destination:=Range("$A$1"))
.Name = "cell" & CStr(MyFileNo) 'cell1～cell10 まで名前
.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 = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

' Range("E2:E400").Select
' Selection.Copy
' Sheets("計算").Select
' ActiveWindow.SmallScroll Down:=-16
' Range("e4").Select
' ActiveSheet.Paste
End Sub

なお、最後のコメントアウト部分の６行が不明です。
data1～data10シートのE列を計算シートに転記されているようですが
計算シートはE4から始まって？
各data1～data10の行は2～400で固定？

お礼

NotFound404さん、ご回答、本当にありがとうございます。
お礼が大変遅くなり申し訳ありません。
（他のマクロのエラーと格闘しておりました(^-^;）

最後の6行は、データを取り込んだ後の次の処理でしたので、今回お聞きしたかったことはばっちり解決しました！（コードを全部書いてくださっているので、当たり前ですよね(汗)）

私自身、よくわかっていない部分が多いので、質問自体もわかりづらかったかと思いますが、根気強く付き合ってくださってありがとうございました！

回答No.4

NotFound404

>こちらで試した限りでは昇順になっていましたが果たして？
は大丈夫でしたかね？

10個のファイルがそれぞれ
一番目→Sheets("data1")
二番目→Sheets("data2")
十番目→Sheets("data10")
に入る。
のなら前回回答を変更して
For i = LBound(FileList) To UBound(FileList)
　　'Debug.Print FileList(i),i
　　Call data取り込み(FileList(i),i+1)
Next

Private Sub data取り込み(MyFileName As String,MyFileNo as integer)
Sheets("data" & cstr(myfileno)).Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myfilename, Destination:=Range("$A$1"))
.Name = "cell" & cstr(myfileno)
以下はあなたのオリジナルのまま
End Sub
で良いかもです。
.Name = "cell" & cstr(myfileno)
の部分に一抹の不安があります。

お礼

ご回答、本当にありがとうございます。
それにもかかわらず、エラーばかりで…。

--------------------------------
For i = LBound(FileList) To UBound(FileList)
'Debug.Print FileList(i),i
Call data取り込み(FileList(i), i + 1) <-----------エラーが出るところ
Next
--------------------------------
上記のところで「コンパイルエラー　ByRef引数の型が一致しません」が出てしまいます。
前回は別のところでコンパイルエラーが出てしまい、いずれも前に進めずにおります。

せっかくご回答くださったのに、それを生かすことができず申し訳ありません。

回答No.3

bin-chan

＃１です。
すでに＃２さんが示されたように、
「ここは新規に作って下さい」の部分を工夫して下さい。

ワークシート上にデータ入力してソートして、上から順に読むも良し。

回答No.2

NotFound404

下記みたいな感じで出来ないかな？
こちらで試した限りでは昇順になっていましたが果たして？
投稿用にタブインデントを全角スペースで代用しています。

Sub test()
　Dim FileList() As Variant, tmpName As Variant
　Dim i As Integer
　With Application.FileDialog(msoFileDialogFilePicker)
　　.AllowMultiSelect = True
　　.InitialFileName = Environ("userProfile") & "\desktop"
　　.Filters.Clear
　　.Filters.Add "テキストファイル", "*.csv;*.txt"
　　　If CBool(.Show) Then
　　　　'選択ファイルのパスの格納
　　　　 ReDim Preserve FileList(.SelectedItems.Count - 1)
　　　　 For Each tmpName In .SelectedItems
　　　　　 FileList(i) = tmpName
　　　　　 i = i + 1
　　　　 Next
　　　End If
　End With

　For i = LBound(FileList) To UBound(FileList)
　　Debug.Print FileList(i)
　　'Call data01取り込み(FileList(i))
　Next
End Sub

Private Sub data01取り込み(MyFileName As String)
'前略
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & MyFileName, Destination:=Range("$A$1"))

'中略
End With

End Sub

お礼

ご回答、ありがとうございます。
頂いた回答をもとにチャレンジしていますが、省略部分がうまく埋められないようで、
エラーばかり出てしまいます…（汗）
この週末に再度、じっくり取り組んでみます。
本当にありがとうございます。

回答No.1

bin-chan

今のコードを最大限流用

Sub data取り込み実行()
'ここは新規に作って下さい
Call data取り込み("data1", "1002.csv")
Call data取り込み("data2", "1234.csv")
Call data取り込み("data3", "3456.csv")
''''以下、略
end sub
Sub data取り込み(strシート名 as string, strファイル名 as string)
' ここは流用
' ' data01取り込み Macro '

'
Sheets(strシート名).Select Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _ "TEXT;C:\Users\user\Desktop\データ\” & strファイル名, Destination:=Range("$A$1")) .Name = "cell1"
''''以下略

お礼

早速のご回答、ありがとうございます！

「(4ケタの数字).csv」の4ケタの数字の部分は、毎回変わります。
これを小さいもの順から取り込むというのは出来ないでしょうか。

さらなる質問となり、申し訳ありません。