みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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
----------------------------------------------------------------

投稿日時 - 2014-02-03 19:31:06

QNo.8459915

暇なときに回答ください

質問者が選んだベストアンサー

失礼しました。
途中までですが以下でどうでしょう?
メニューの挿入から標準モジュールに張り付けてお試しください。
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

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

投稿日時 - 2014-02-14 15:54:26

お礼

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

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

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

投稿日時 - 2014-02-16 10:57:57

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.4

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

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)
の部分に一抹の不安があります。

投稿日時 - 2014-02-08 08:15:13

お礼

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

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

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

投稿日時 - 2014-02-13 20:33:52

ANo.3

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

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

投稿日時 - 2014-02-04 01:36:44

ANo.2

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

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

投稿日時 - 2014-02-04 00:04:45

お礼

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

投稿日時 - 2014-02-07 21:30:55

ANo.1

今のコードを最大限流用


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"
''''以下略

投稿日時 - 2014-02-03 21:39:31

お礼

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

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

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

投稿日時 - 2014-02-03 23:45:44

あなたにオススメの質問