[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダーの中にあるCSVファイルのシートデータをコピー』（狭山）
お世話になっております。 どうぞよろしくお願いいたします。
携帯管理簿と名前のフォルダーがあります。 その中にファイル名がバラバラなCSVファイルが数十個あり 各ファイルの中のシートは１つしかないのですが名前もバラバラです。 また、各シートのデータ数量（行）も違います。
行いたいことですが １、新規で作成したエクセルファイルを開きます ２、マクロを実行すると”フォルダーの参照画面が出てきて 携帯管理簿と名前のフォルダーを選択 ３、各ファイルのシートのA〜Iに入っているデータを下記のようにコピー
A B C D E F G H I 1 電話番号 通信年月日 曜日 通信開始時刻 通信先電話番号 通信先 通信時間 通信料 通信種類 2 090-1234-5678 2017/6/5 月 9:16 01-234-5678 東京 00:44.5 100 スマホ 3 090-1234-5679 2017/6/5 月 9:18 01-234-5679 神奈川 00:28.0 100 スマホ 4 090-1234-5680 2017/6/5 月 10:19 01-234-5680 千葉 05:13.5 100 スマホ 5 090-1234-5681 2017/6/5 月 10:35 01-234-5681 埼玉 01:20.0 100 スマホ
A B C D E F G H I 1 電話番号 通信年月日 曜日 通信開始時刻 通信先電話番号 通信先 通信時間 通信料 通信種類 2 090-1234-5682 2017/6/5 月 11:40 01-234-5682 東京 03:13.5 100 スマホ 3 090-1234-5683 2017/6/5 月 13:10 01-234-5683 神奈川 00:32.5 100 スマホ
A B C D E F G H I 1 電話番号 通信年月日 曜日 通信開始時刻 通信先電話番号 通信先 通信時間 通信料 通信種類 2 090-1234-5684 2017/6/5 月 13:44 01-234-5684 千葉 01:17.5 100 スマホ 3 090-1234-5685 2017/6/5 月 14:19 01-234-5685 埼玉 00:48.0 100 スマホ 4 090-1234-5686 2017/6/5 月 15:05 01-234-5686 東京 00:18.5 100 スマホ
マクロ実行後
A B C D E F G H I 1 電話番号 通信年月日 曜日 通信開始時刻 通信先電話番号 通信先 通信時間 通信料 通信種類 2 090-1234-5678 2017/6/5 月 9:16 01-234-5678 東京 00:44.5 100 スマホ 3 090-1234-5679 2017/6/5 月 9:18 01-234-5679 神奈川 00:28.0 100 スマホ 4 090-1234-5680 2017/6/5 月 10:19 01-234-5680 千葉 05:13.5 100 スマホ 5 090-1234-5681 2017/6/5 月 10:35 01-234-5681 埼玉 01:20.0 100 スマホ 6 090-1234-5682 2017/6/5 月 11:40 01-234-5682 東京 03:13.5 100 スマホ 7 090-1234-5683 2017/6/5 月 13:10 01-234-5683 神奈川 00:32.5 100 スマホ 8 090-1234-5684 2017/6/5 月 13:44 01-234-5684 千葉 01:17.5 100 スマホ 9 090-1234-5685 2017/6/5 月 14:19 01-234-5685 埼玉 00:48.0 100 スマホ 10 090-1234-5686 2017/6/5 月 15:05 01-234-5686 東京 00:18.5 100 スマホ どうぞご教授お願いいたします。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
（マナ） 2017/08/05(土) 22:50
ご返信ありがとうございました。 Sub Macro1() ' ' Macro1 Macro '
'
Range("A1:I91").Select
Selection.Copy
Windows("Book1").Activate
ActiveSheet.Paste
End Sub
新規Book1を仮に作りまして携帯管理簿のフォルダーの中にあるファイルの１つのシートを コピーして貼り付けの記録を行いました。 後はどうすればよろしいのでしょうか。 ご教授願います。 （狭山） 2017/08/05(土) 23:17
Option Explicit
Sub test()
Dim myFld As String, myCSV As String
myFld = "C:\***:\***\"
myCSV = "******.csv"
Workbooks.Open myFld & myCSV
End Sub
（マナ） 2017/08/06(日) 00:01
フォルダ内の全てのCSVファイルを開くのは、エクセルの機能だけではできないので、FileSystemObjectというものを使います。詳細はネットで調べてみてください。
詳しい説明は敢えてしません。FileDialog,FileSystemObject,セルの選択方法,Sortメソッドなどを調べてみて、自分で読み解いてください。それでもわからないことがあったら言ってください。
以下がコードの骨格です。エラー処理はしていないので、必要があれば付け足してください。
Option Explicit
Sub CopyFromFiles()
Dim dlg As FileDialog, fpath As String
Dim fso As Object, fc As Object, f As Object
Dim wb As Workbook, ws As Worksheet
Dim csv As Workbook, hyou As Worksheet, buf As Variant
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
.AllowMultiSelect = False
.Title = "フォルダーの参照"
.Filters.Clear
If .Show = False Then
Exit Sub
End If
fpath = .SelectedItems(1)
End With
Set dlg = Nothing
Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set ws = wb.Worksheets(1)
buf = Array("電話番号", "通信年月日", "曜日", "通信開始時刻", "通信先電話番号", "通信先", "通信時間", "通信料", "通信種類")
ws.Range(Cells(1, 1), Cells(1, 9)) = buf
Set fso = CreateObject("Scripting.FileSystemObject")
Set fc = fso.GetFolder(fpath).Files
For Each f In fc
If fso.GetExtensionName(f.Path) = "csv" Then
Set csv = Workbooks.Open(f.Path)
Set hyou = csv.Worksheets(1)
hyou.Activate
hyou.Range(Cells(2, 1), Cells(2, 1).End(xlDown).End(xlToRight)).Copy
Set hyou = Nothing
ws.Activate
ws.Cells(1, 1).End(xlDown).End(xlToRight).Activate
ActiveCell.Offset(1, 0).Activate
ws.Paste
csv.Close False
Set csv = Nothing
End If
Next
Set f = Nothing
Set fc = Nothing
Set fso = Nothing
ws.Range(Cells(1, 1), Cells(1, 1).End(xlDown).End(xlToRight)).Sort ws.Cells(1, 4)
Set ws = Nothing
wb.Activate
Set wb = Nothing
Application.ScreenUpdating = True
MsgBox "完了しました"
End Sub
（:;:;:;:;:;） 2017/08/06(日) 00:46
（:;:;:;:;:;）さんありがとうございました。 FileSystemObjectとFileDialog,FileSystemObject,のことですが ダイアログで指定したフォルダの中のファイル一覧を取得する とかいろいろとあって理解が出来ませんでした。 （:;:;:;:;:;）さんの教えていただいたマクロを実行すると ActiveCell.Offset(1, 0).Activateの部分がエラーとなってしまいます。
（マナ）さまの教えていただきました方ですが
myFld = "C:\***:\***\" ←C:\Users\PCUSER\Desktopと変更しました
myCSV = "******.csv" ←実際のCSVのファイル名を入れてみましたが
Workbooks.Open myFld & myCSVにエラーが出てしまいます。
ご教授お願いいたします。
（狭山） 2017/08/06(日) 10:04
横から失礼します。
>myFld = "C:\***:\***\" ←C:\Users\PCUSER\Desktopと変更しました
↓のようにしましたか？
myFld = "C:\Users\PCUSER\Desktop\"
↓になってませんか？
myFld = "C:\Users\PCUSER\Desktop" （カリーニン） 2017/08/06(日) 10:08
myFld = "C:\Users\PCUSER\Desktop\"
の代りに
myFld = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
としてもいいですね。 （カリーニン） 2017/08/06(日) 10:20
これで試してください。
Sub test()
Dim cn As Object, rs As Object, myDir As String, fn As String, n As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Text;HDR=NO"
End With
n = 1
fn = Dir(myDir & "*.csv")
Do While fn <> ""
cn.Open myDir
cn.CursorLocation = 3
Set rs = cn.Execute("SELECT * FROM " & fn)
Cells(n, 1).CopyFromRecordset rs
n = n + rs.RecordCount
rs.Close: cn.Close
cn.Properties("Extended Properties") = "Text;HDR=YES"
fn = Dir
Loop
Set cn = Nothing: Set rs = Nothing
End Sub
（ seiya） 2017/08/06(日) 10:56
ws.Cells(1, 1).End(xlDown).End(xlToRight).Activate ActiveCell.Offset(1, 0).Activate
↓
If ws.Cells(2, 1) = "" Then
ws.Cells(2, 1).Activate
Else
ws.Cells(2, 1).End(xlDown).Offset(1, 0).Activate
End If
（:;:;:;:;:;） 2017/08/06(日) 11:08
（カリーニン）さん（ seiya）さん（:;:;:;:;:;）さん（マナ）さん
皆さん本当にありがとうございます。
（:;:;:;:;:;）さんのを実行しましたがデータの移行はできました。
しかし、タイトル行が最終列にきてしまいまして。
（カリーニン）さんの
myFld = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"で開きました。
でも、今回は（ seiya）さんのマクロを使用させていただきたいと思います
（ seiya）さんのマクロの式でご質問があるのですが たとえば、今回はフォルダーの中にCSVファイルでしたが エクセルファイルの場合どこを変更すれば使用できますでしょうか。 (とても便利で活用性があるためにお聞きしたく）
また、大変申し訳がないのですが１つ忘れていたことがありまして マクロ実行後、AとEは電話番号が転記されますが AとEの番号が誰の番号かをリストと言う別のシート名を参考に R列とS列に表示が出来ればと
例 A B C D 1 電話番号 使用者 通信先電話番号 使用者 2 090-1234-5678 A氏01 01-234-5678 E氏05 3 090-1234-5680 B氏01 01-234-5680 F氏06 4 080-1234-0000 C氏03 080-1234-0000 G氏07 5 080-1234-0001 D氏04 080-1234-0001 H氏08
マクロ実行後に、別のリストシート（上記）に基づきR列とS列に結果を表示させたいのですが
A E R列 S列 1 電話番号 通信先電話番号 2 090-1234-5678 01-234-5678 A氏01 E氏05 3 090-1234-5679 01-234-5679 該当無し 該当無し 4 090-1234-5680 01-234-5680 B氏01 F氏06 5 090-1234-5681 01-234-5681 該当無し 該当無し
１回で質問できなくて大変申し訳ございませんが ご教授お願いいたします。 （狭山） 2017/08/06(日) 17:19
1) "Text;HDR=NO" を "Excel 12.0;HDR=No;" に変更してください。
HDR=YES の場合は2行目から、NOの場合は1行目からになります。
2) Set rs = cn.Execute("SELECT * FROM " & fn)
fn の部分はシート名をかぎかっこで括って$を付与した形になります。
例：シート名がSheet1の場合 "SELECT * FROM [Sheet1$]"
3) >R列とS列に結果を表示させたいのですが VLookup関数でなんとかなりませんか？ （ seiya） 2017/08/06(日) 18:51
有難うございます。
早速、先ほどのCSVファイルをエクセルファイルに変更し行いましたが
実行後はシート一面何も表示されません。
以下に変更したのですが。
Sub test()
Dim cn As Object, rs As Object, myDir As String, fn As String, n As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=No;"
End With
n = 1
fn = Dir(myDir & "*.csv")
Do While fn <> ""
cn.Open myDir
cn.CursorLocation = 3
Set rs = cn.Execute("SELECT * FROM " & fn)
Cells(n, 1).CopyFromRecordset rs
n = n + rs.RecordCount
rs.Close: cn.Close
cn.Properties("Extended Properties") = "Text;HDR=YES"
fn = Dir
Loop
Set cn = Nothing: Set rs = Nothing
End Sub
3) >R列とS列に結果を表示させたいのですが VLookup関数でなんとかなりませんか？
R2=IF(A2="","",VLOOKUP(A2,リスト!$A:$B,2,FALSE)) S2=IF(A2="","",VLOOKUP(A2,リスト!$A:$B,2,FALSE)) こちらで出来ました。 ただ、マクロで出来るかと思ったもので。 申し訳ございませんが、前題の件、ご教授お願いいたします。
（狭山） 2017/08/06(日) 20:19
おっと、
fn = Dir(myDir & "*.csv")
これも
fn = Dir(myDir & "*.xls")
に変更ですね。
（ seiya） 2017/08/06(日) 20:39
数式が判明すれば
fn = Dir
Loop
'↓ ここから
With Cells(1).CurrentRegion.Columns("R:S")
.Offset(1).Resize(.Rows.Count-1).Formula = _
Array("=IF(A2="""","""",VLOOKUP(A2,リスト!$A:$B,2,FALSE))","=IF(A2="""","""",VLOOKUP(A2,リスト!$A:$B,2,FALSE))")
End with
'↑ここまで
Set cn = Nothing: Set rs = Nothing
を追加すればいいと思いますが... （ seiya） 2017/08/06(日) 20:48
有難うございます。 fn = Dir(myDir & "*.xls")に変更してみたのですが cn.Open myDirが黄色くなってしまいやはり駄目でした。 また先ほどの私が出来ましたと言ったVLookup式ですが リストのA列に該当の電話番号がない場合 R S は#N/Aになってしまいますので、A列に該当の電話番号がない場合は”該当無し”にしたいのですが 何度も申し訳ございませんがご教授お願いします。
（狭山） 2017/08/06(日) 21:18
1) こちらで試してください
Sub test()
Dim cn As Object, rs As Object, myDir As String, fn As String
Dim n As Long, i As Long, flg As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
n = 2
fn = Dir(myDir & "*.xls")
Do While fn <> ""
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0"
.Open myDir & fn
.cursorlocation = 3
End With
rs.Open "SELECT * FROM [Sheet1$]", cn, 3
If Not flg Then
For i = 0 To rs.Fields.Count - 1
Cells(1, i + 1).Value = rs.Fields(i).Name
Next
End If
Cells(n, 1).CopyFromRecordset rs
n = n + rs.RecordCount
rs.Close: cn.Close: flg = True
fn = Dir
Loop
Set cn = Nothing: Set rs = Nothing
End Sub
2)
Array("=IFERROR(VLOOKUP(A2,リスト!$A:$B,2,FALSE),""該当無し"")","=IFERROR(VLOOKUP(A2,リスト!$A:$B,2,FALSE),""該当無し"")")
かな？ （ seiya） 2017/08/06(日) 22:20
有難うございます。
1) を試してみましたが
rs.Open "SELECT * FROM [Sheet1$]", cn, 3が黄色くなってしまいまして
2) はCSVの方のマクロで試したところ完璧です。
Array("=IFERROR(VLOOKUP(A2,リスト!$A:$B,2,FALSE),""該当無し"")","=IFERROR(VLOOKUP(E2,リスト!$A:$B,2,FALSE),""該当無し"")")
後の方はA2ではなくE2でした。
ご教授お願いいたします。
（狭山） 2017/08/06(日) 22:49
シート名はSheet1で間違いありませんか？ PCは落としましたので明日また... （seiya） 2017/08/06(日) 23:18
おはようございます。 大変申し訳ございません。 同じCSVデータを開き 名前を付けて保存、形式をエクセルにしただけでしたので 今回のエラーが出てしまいました。 CSVを開きコピー新たなファイルへ貼り付けを行いテストを行った結果 出来ました。 大変お騒がせ致しまして申し訳ございません。 （seiya）さん 最後まで本当にありがとうございました。 機会がございましたら、よろしくお願い致します。 米今日から早速に使用して見ます。
（狭山） 2017/08/07(月) 07:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.