• 締切済み

複数の.csvファイルから指定数値を取り出す

毎度御世話になります。 あるフォルダ内の複数の.csvファイル一つ一つから 指定数値(B列6行目のみ)を取り出して、 デスクトップ上、別のExcelシートの(B列1行毎に日付と時間が書いてある) 隣のC列にまとめて自動で書いてくれるプログラムを考えます。 使用するファイル名は HU20150513_110000_AI2.csv です。 コードの該当行'ファイル名を配列変数に格納 のところを、 上記ファイル名にしても、「型が一致しません」とエラーが出るのですが、 どこか他に変更点があるのでしょうか。詳しい方、宜しく御願い申し上げます。 ■VBAコード Sub 値取得() '配列変数を宣言 Dim filnames As Variant Dim myfile As Variant Dim cnt As Long Dim mybook As Workbook Dim outbook As Worksheet Dim fname As String Dim mySerial As Date Dim myRng As Variant Dim key As String '出力先の先頭行番号 cnt = 1 '出力先のブックを格納 Set outbook = ActiveWorkbook.ActiveSheet 'ファイル名を配列変数に格納 filnames = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", MultiSelect:=True) 'キャンセル時の処理 If IsArray(filnames) = False Then Exit Sub 'ファイルの数だけ繰り返し Application.ScreenUpdating = False For Each myfile In filnames   'ファイル開く   Set mybook = Workbooks.Open(Filename:=myfile, ReadOnly:=True)   'ファイル名からシリアル値の作成   fname = Format(Left(mybook.Name, 12), "0000/00/00 00:00")   mySerial = DateValue(fname) + TimeValue(fname)   '値を取得・出力先へ書き出し   mybook.Activate   key = Year(mySerial) & Month(mySerial) & Day(mySerial) & Hour(mySerial)   For Each myRng In outbook.Columns("B").SpecialCells(xlCellTypeConstants, 23)     If IsDate(myRng) Then       If Year(myRng) & Month(myRng) & Day(myRng) & Hour(myRng) = key Then         myRng.Offset(0, 1).Value = ActiveSheet.Range("B6").Value         Exit For       End If     End If   Next myRng   'ファイル閉じる   Application.DisplayAlerts = False   Workbooks(mybook.Name).Close   Application.DisplayAlerts = True   'カウントアップ   cnt = cnt + 1 Next myfile Application.ScreenUpdating = True End Sub

みんなの回答

  • chie65535
  • ベストアンサー率43% (8514/19356)
回答No.3

>ファイルは上記一つだけでなく、HU20150513_120000_AI1 ・・のように1h毎に一つあります。 であれば、 Dim filelists(24) As String Dim filnames As Variant filelists(1) = "C:\Users\ユーザー名\Desktop\HU20150513_000000_AI1.csv" filelists(2) = "C:\Users\ユーザー名\Desktop\HU20150513_010000_AI1.csv" filelists(3) = "C:\Users\ユーザー名\Desktop\HU20150513_020000_AI1.csv" filelists(4) = "C:\Users\ユーザー名\Desktop\HU20150513_030000_AI1.csv" filelists(5) = "C:\Users\ユーザー名\Desktop\HU20150513_040000_AI1.csv" filelists(6) = "C:\Users\ユーザー名\Desktop\HU20150513_050000_AI1.csv" (略) filelists(22) = "C:\Users\ユーザー名\Desktop\HU20150513_210000_AI1.csv" filelists(23) = "C:\Users\ユーザー名\Desktop\HU20150513_220000_AI1.csv" filelists(24) = "C:\Users\ユーザー名\Desktop\HU20150513_230000_AI1.csv" ってやって filnames = Array(ファイル名) を filnames = filelists に変えましょう。 リストを1時間毎に24個代入する所は、for分を使って1~24まで回して、ファイル名の時間に相当する所を、文字列式で生成する事も可能です。

  • chie65535
  • ベストアンサー率43% (8514/19356)
回答No.2

>ファイルがフォルダ内に入っているからでしょうか。 指定したファイルがカレントドライブのカレントフォルダに無い場合、ファイル名だけ指定しても開けません。 filnames = Array("C:\Users\ユーザー名\Desktop\HU20150513_110000_AI2.csv") のように、ファイルの場所を明示的に指定するか filnames = Array("HU20150513_110000_AI2.csv") ChDrive "C" ChDir ""C:\Users\ユーザー名\Desktop" のように、カレントドライブを変更してから、カレントフォルダを変更して下さい。

komet115
質問者

補足

filnames = Array("C:\Users\ユーザー名\Desktop\HU20150513_110000_AI2.csv") のように変更して、実行してみましたところ、また「型が一致しません」と出ます。 ファイルは上記一つだけでなく、HU20150513_120000_AI1 ・・のように1h毎に一つあります。 それらの指定数値だけまとめて別に表示させるようにしたいのです。

  • chie65535
  • ベストアンサー率43% (8514/19356)
回答No.1

>コードの該当行'ファイル名を配列変数に格納 のところを、 >上記ファイル名にしても、「型が一致しません」とエラーが出るのですが、 ファイル名を「固定の値、1つだけ」にするには 'ファイル名を配列変数に格納 filnames = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", MultiSelect:=True) を 'ファイル名を配列変数に格納 filnames = Array("HU20150513_110000_AI2.csv") に変えます。 'ファイル名を配列変数に格納 filnames = "HU20150513_110000_AI2.csv" ってやっちゃうと「バリアント型には、固定長の文字列型(String)と、ユーザー定義型は代入できない」ので「型が一致しません」エラーになります。

komet115
質問者

補足

回答ありがとうございます。 早速試したところ、 上記「ファイルが見つかりません」とエラーが出ました。 ファイルがフォルダ内に入っているからでしょうか。

関連するQ&A

  • VBAで複数ファイルのページ数出力

    Win10のOffice365のExcelを使用しています。 GetOpenFilenameで選択した複数のExcelファイルのファイル名+印刷ページ数を マクロを実行したファイルに出力するというマクロを作成しました。 マクロを実行する度に既存データがあれば追加されていくようにしたいのですが、上手くいきません。 それどころか、実行時も複数ファイル選択したにも関わらず、 1ファイルのデータしか出力されない状態です。 実行後のイメージは添付ファイルの通りです。 (A1、A2はデフォルトで入力しています。) 勉強を始めたばかりなので改善点もあれば、教えて頂きたいです。 よろしくお願い致します。 ================================================= Option Explicit Sub pagecount() Dim Page As Long, cnt As Long, xlcnt As Long Dim fs As Variant, path As Variant Dim Fname As String Dim i As Integer Dim wb1 As Workbook, wb2 As Workbook Dim sh As Worksheet With CreateObject("WScript.Shell") .CurrentDirectory = ThisWorkbook.path End With fs = Application.GetOpenFilename(filefilter:="Microsoft Excelブック,*.xls*", MultiSelect:=True) If IsArray(fs) Then For Each path In fs Set wb1 = Workbooks.Open(path, , True) Set wb2 = ThisWorkbook Do Until (Fname = "") Page = 0 For Each sh In wb1.Worksheets Page = Page + sh.PageSetup.Pages.Count Next sh xlcnt = Cells(Rows.Count, 1).Row cnt = Cells(xlcnt, 1).End(xlUp).Row If wb2.ActiveSheet.Cells(cnt, 1).Value <> "" Then wb2.ActiveSheet.Cells(cnt, 1).Value = Fname wb2.ActiveSheet.Cells(cnt, 1).Offset(0, 1) = Page wb1.Close savechanges:=False Fname = Dir() cnt = cnt + 1 End If Loop Next path End If End Sub

  • Excelマクロでフォルダ内のCSVファイルを一括で読み込ませるには?

    Excelファイルと同階層にあるCSVファイルを読み込ませるマクロを作ってみたのですが、正常に動作しません。 アドバイスいただければ幸いです。 Excel2003を使用しています。 Sub 同階層フォルダ内のCSV読込_Click() Dim fname As String 'ファイル名 Dim pathname As String 'パス名 Dim dat(1 To 4) As Variant '読み込んだデータ Dim rr As Long '対象行番号 Dim i As Integer '列のオフセット Dim j As Integer 'ファイル識別番号のオフセット '同階層フォルダ内のCSVファイルを参照 pathname = ".\*.csv" fname = Dir(pathname, vbNormal) 'データを挿入する行番号 rr = 2 '該当するファイルがある間 Do While fname <> "" j = 0 j = j + 1 'ファイルを開く Open fname For Input As #j 'ファイルの終端まで Do Until EOF(j) 'データを取得 Input #j, dat(1), dat(2), dat(3), dat(4) '読み込んだデータをセルに出力 For i = 1 To 4 Cells(rr, i).Value = dat(i) Next '行番号を更新 rr = rr + 1 Loop Close #j 'フォルダ内の次のファイルを検索 fname = Dir() Loop End Sub

  • エクセルからCSVファイルに出力したい?

    エクセルのシートからマクロを使ってCSVファイルに出力したいです。 そこで調べたのですが、 http://oshiete1.goo.ne.jp/kotaeru.php3?q=2376607 こちらの質問で以下のようなコードが参考になりました。 Sub Macro1() Dim myBook As String myBook = ActiveWorkbook.FullName myBook = Left(myBook, Len(myBook) - 3) & "CSV" ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=myBook, FileFormat:=xlCSV ActiveWindow.Close False End Sub このコードではCSVのファイル名がエクセルシートのファイル名になってしまいます。 今回の質問ですが、CSVファイルを違う名前で保存するにはどのようにすればいいのでしょうか? (CSVファイルの名前は常にabc.csvで保存するものとします)

  • エクセルVBAでのCSV出力方法について

    エクセルVBAを使ってCSVを出力しようとしているのですが、 狙った範囲を上手くCSV化することが出来ずに苦戦しています。 どなたかアドバイスを頂けませんでしょうか。 使用してるエクセルは2010になります。 シート2のコマンドボタンを押すことでシート1の内容をCSV化したいと考えています。 シート1のA1に入力した内容がCSVのタイトルになります。 2行目はヘッダーですが、CSVには反映しないように制御をかけています。 ↓が実際に書いてみたVBAですが、どうしてもシート1の内容を持ってきてしまいます。 どのように改修したらシート2の内容を持ってこれるでしょうか。 Private Sub CommandButton1_Click() Dim MyFile, FileType, Prompt As String Dim FileNamePath As Variant Dim StartRow, StartCol, EndRow, EndCol As Integer Dim Rowcnt, Colcnt As Integer Dim UsedCell As Range Dim ch1 As Long '対象のシートをアクティブにする Worksheets("シート1").Activate 'ファイル名の取得 MyFile = ActiveSheet.Range("A1") & ".csv" FileType = "CSV ファイル (*.csv),*.csv" Prompt = "保存するファイルの名前を付けてください" '保存するファイルのパスを取得します FileNamePath = SaveFileNamePath(MyFile, FileType, Prompt) If FileNamePath = False Then 'キャンセルボタンが押された End End If '空いているファイル番号を取得します ch1 = FreeFile 'FileNamePath のファイルをオープンします Open FileNamePath For Output As #ch1 '使用しているセルの取得 Set UsedCell = ActiveSheet.UsedRange StartRow = UsedCell.Cells(3).row StartCol = UsedCell.Cells(1).Column EndRow = UsedCell.Cells(UsedCell.Count).row EndCol = UsedCell.Cells(UsedCell.Count).Column For Rowcnt = StartRow To EndRow For Colcnt = StartCol To EndCol - 1 '改行を挿入しないで書き出す ; を最後に付ける Write #ch1, Cells(Rowcnt, Colcnt); Next '改行を挿入する Write #ch1, Cells(Rowcnt, EndCol) Next 'ファイルを閉じます Close #ch1 End Sub Function SaveFileNamePath(MyFile, FileType, Prompt) As Variant SaveFileNamePath = Application.GetSaveAsFilename(MyFile, FileType) End Function アドバイスを頂けたらと思います。 どうぞ宜しくお願いします。

  • 自動範囲指定のデータをCSVで保存したい。

    添付ファイルにあるようにデータ(量が変化します)があり、自動的に最後の行まで指定してその範囲をダイヤログボックスを表示させてCSVとして保存したい。 今特に問題がある点は、 ・データのやり取りが出来ない点 ・CSVとして保存できない。(上記の点においてブランクの表が作成される) 何卒宜しくお願い致します。 '現在開いているシートをCSVデータで保存する Public Sub call_RangeSaveCSV() Dim fPath As String Dim fName As String Dim rng As Range Dim folderPath As String Fldr = "ダウンロード" '現在開いているブック情報をファイル名にするため、変数に格納 fPath = ActiveWorkbook.path & "\" fName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "csv" Application.DisplayAlerts = False '現在選択しているセル情報をrngに格納 'Set Rng = Selection Set rng = Range("L6").CurrentRegion '新規ブック作成→rngをA1にコピー→CSV保存→CSV閉じる Workbooks.Add rng.Copy ActiveSheet.Range("A1") '■ここでエラーが返ってきます。ダイヤログボックスを出して任意の場所と名前を付けたいのですが。。 ActiveWorkbook.SaveAs FileName:=fPath & fName, FileFormat:="Sample.csv", FileFilter:="CSVファイル(*.csv),*.csv") ActiveWorkbook.SaveAs ActiveWindow.Close Application.DisplayAlerts = True End Sub

  • GetOpenFilenamのパス指定

    Access2000VBAを使用するのが前提です。 「ダイアログを表示してファイルを選択しフォームに表示する」ファンクションがあります。(下記参考モジュール参照ください:excel 9.0 object Libraryを使用してます) ダイアログを表示した際、指定のフォルダの内容を表示したいのですが、「(1)ChDir」も「(2)SetCurrentDirectory」を使用しても規定フォルダが表示され指定フォルダに移行しません。 何か手段はありますか?ダイアログ自体は問題なく機能してます。 Public Function ふぁいる選択() Dim myFile As Variant, P Dim exlDlg As New Excel.Application P = CurrentProject.Path & "\" ChDrive "C" ChDir P '>>>>>>>(1) Call SetCurrentDirectory(P)   '>>>>>>>>(2) myFile = exlDlg.GetOpenFilename("CSVファイル(*.csv),*契約*.csv") If (VarType(myFile) = vbBoolean) Or (myFile = "False") Then ふぁいる選択 = "" Else ふぁいる選択 = myFile End If End Function

  • VBA:2つのCSVファイルを開きたいです。

    エクセル2010のVBAにてCSVファイルを開き結合させるプログラムを組もうとしているのですが、2つ目のCSVファイルを開こうとすると、何故かエラーが出てしまいます。 -------------------------------------------------------------------------------- 1つ目 Sub mobile_FileSearch(Path As String) 'test.csvのデータを検索して開く Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call mobile_FileSearch(Folder.Path) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name = "test.csv" Then Workbooks.Open ("test.csv") End If Next File End Sub ---------------------------------------------------------------------------- 2つ目 Sub local_FileSearch(Path As String) 'bbb.csvのデータを検索して開く Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call local_FileSearch(Folder.Path) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name = "bbb.csv" Then Workbooks.Open ("bbb.csv")'←ここでエラー End If Next File End Sub ------------------------------------------------------------------------ まったく同じプログラムで、csvファイル名だけ変えただけで実行時エラー1004が出てしまいます。 一体全体何が問題なのでしょうか?

  • ファイルオープンの速度を速くするには?

    よろしくお願いします。 下記コードでabc.csvを選択すると、Excelツールバーの”開く”で行う場合よりかなり時間がかかります。速度を早くする方法を教えて頂けないでしょうか。 Option Explicit Option Compare Text Sub Start_Click() Dim Fname As String Dim MBErr As Integer MsgBox "abc.csv を選択して下さい" Start: Fname = Application.GetOpenFilename("CSVファイル,*.csv") If Not Right(Fname, 7) = "abc.csv" Then   MBErr = MsgBox("ファイル名が違うか、ファイルが選択されていません" _          & Chr(13) & Chr(13) & "abc.csv を選択して下さい", 21)   If MBErr = 4 Then     GoTo Start   Else     Exit Sub   End If End If Workbooks.Open Fname End Sub

  • 複数ファイルの1つのシート中の総行数を求めるには

    大変お世話になっております。 複数ファイルの1つのシート(カテーログ)中の最終行数を求めるのに、下記のマクロを書いて実行しましたが、エラーは出ませんが総行数など、何も反応がありません。なにも出力しない原因がお分かりでしたら、ご教示頂けると大変たすかります。まだまだマクロは超初心者です。 出力したい情報は、ファイル名とA列の3行目~最終行の総行数です。 Sub データ総行数求め() Dim fpath As String, fname As String Dim wb As Workbook, ws As Worksheet Dim crow As Long, cnt As Long fpath = "C:\Users\Owner\Documents\連結作業\202304-202309\)" fname = Dir(fpath & "*.xlsx") Set ws = ThisWorkbook.Worksheets("test") crow = 1 Do Until (fname = "") Set wb = Workbooks.Open(fpath & fname) If (sheet_chk(wb, "カテーログ") = True) Then cnt = count_row(wb.Worksheets("カテーログ")) Worksheets("カテーログ").Range("A3").Value ws.Cells(crow, 1).Value = fname ws.Cells(crow, 2).Value = "カテーログ" ws.Cells(crow, 3).Value = cnt crow = crow + 1 End If wb.Close fname = Dir() Loop End Sub '戻り値の定義 Function count_row(ByVal ws As Worksheet) As Long Dim k As Long, tmp As Long count_row = 0 For k = 1 To 256 tmp = ws.Cells(ws.Rows.Count, k).End(xlUp).Row If (tmp > count_row) Then count_row = tmp Next End Function Function sheet_chk(ByVal wb As Workbook, ByVal msg As String) As Boolean Dim w As Worksheet sheet_chk = False For Each w In wb.Worksheets If (w.Name = msg) Then sheet_chk = True Exit For End If Next End Function

  • CSVから構造体へ代入

    お世話になります。 Private Type TestRecord Col1 As String * 255 Col2 As String * 255 Col3 As String * 255 End Type Sub ボタン1_Click() Dim FName As String Dim FileNo As Integer Dim LineData As String Dim TestRec() As TestRecord FileNo = FreeFile '選択したファイル名の取得 FName = Application.GetOpenFilename("CSV ファイル (*.CSV),*.CSV") If FName = "False" Then Exit Sub End If Open FName For Input As #FileNo Do Until EOF(FileNo) i = i + 1 Line Input #FileNo, LineData ReDim TestRec(i) TestRec() = Split(LineData, ",") Debug.Print buf Loop Close #FileNo End Sub ファイルの中身 "テストID1","テスト姓1","テスト名1" "テストID2","テスト姓2","テスト名2" 以上のコードを実行するとTestRec() =~の部分で型が一致しません とエラーが出てしまいます。 よき解決方法があれば教えてください。宜しくお願いします。

専門家に質問してみよう