Excel VBA 逆引き集 | 外部ファイルを取り込むテンプレ

Excel VBA
スポンサーリンク

外部ファイルを取り込むテンプレ

毎回「開く→コピー→貼り付け」を手でやるのは卒業。ここにあるテンプレをそのまま貼れば、ExcelやCSV/TSV/テキストを安全・高速に取り込めます。初心者向けに、使い分けと落とし穴対策まで一気にまとめます。

共通の安全ラップとユーティリティ

'共通：安全ラップ（画面更新/イベント/再計算の一時停止＋復帰）
Sub Import_SafeWrapStart()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Sub Import_SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'共通：存在チェック（Trueなら存在）
Public Function FileExists(ByVal path As String) As Boolean
    FileExists = (Dir(path) <> "")
End Function
VB
  • 基本姿勢: 重い取り込みの前後は「停止→処理→復帰」。これだけで体感が変わります。
  • 存在確認: Dirで早めに弾き、ユーザーに優しく。

Excelブックの取り込み（シート/範囲のコピー）

'1) 指定ブックの先頭シートを丸ごとコピーして末尾に追加
Sub Import_ExcelSheet_Copy()
    Dim src As String: src = ThisWorkbook.Path & "\Input\Source.xlsx"
    If Not FileExists(src) Then MsgBox "見つかりません: " & src: Exit Sub

    Import_SafeWrapStart

    Dim wb As Workbook, shCount As Long
    Set wb = Workbooks.Open(src, ReadOnly:=True, UpdateLinks:=False)
    shCount = ThisWorkbook.Worksheets.Count
    wb.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(shCount)
    wb.Close SaveChanges:=False

    Import_SafeWrapEnd
End Sub

'2) 指定範囲だけ値コピー（軽量・安全）
Sub Import_ExcelRange_Copy()
    Dim src As String: src = ThisWorkbook.Path & "\Input\Source.xlsx"
    If Not FileExists(src) Then MsgBox "見つかりません: " & src: Exit Sub

    Import_SafeWrapStart

    Dim wb As Workbook
    Set wb = Workbooks.Open(src, ReadOnly:=True, UpdateLinks:=False)
    Worksheets("Import").Range("A1:D1000").Value = wb.Worksheets(1).Range("A1:D1000").Value
    wb.Close SaveChanges:=False

    Import_SafeWrapEnd
End Sub
VB
  • 使い分け:
    • シート丸ごと: 体裁ごと欲しいとき。
    • 範囲だけ: 値のみで十分なとき（高速・安全）。

CSV/TSVの取り込み（型と文字コードを制御）

'CSV：QueryTablesで型とクォートを制御（安定）
Sub Import_Csv_QueryTables()
    Import_SafeWrapStart
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & ThisWorkbook.Path & "\input.csv", Destination:=Range("A1"))
        .TextFileCommaDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileColumnDataTypes = Array(xlTextFormat, xlGeneralFormat, xlGeneralFormat) '先頭ゼロ保持→テキスト
        .Refresh BackgroundQuery:=False
    End With
    Import_SafeWrapEnd
End Sub

'TSV：タブ区切り
Sub Import_Tsv_QueryTables()
    Import_SafeWrapStart
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & ThisWorkbook.Path & "\input.tsv", Destination:=Range("A1"))
        .TextFileTabDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileColumnDataTypes = Array(xlTextFormat, xlGeneralFormat)
        .Refresh BackgroundQuery:=False
    End With
    Import_SafeWrapEnd
End Sub

'OpenText：CSV/TSVをブックとして開く（列型指定可）
Sub Import_OpenText_Csv()
    Workbooks.OpenText Filename:=ThisWorkbook.Path & "\input.csv", _
        DataType:=xlDelimited, Comma:=True, Local:=True, _
        TextQualifier:=xlTextQualifierDoubleQuote, _
        FieldInfo:=Array(Array(1, 2), Array(2, 1), Array(3, 1))
End Sub

Sub Import_OpenText_Tsv()
    Workbooks.OpenText Filename:=ThisWorkbook.Path & "\input.tsv", _
        DataType:=xlDelimited, Tab:=True, Local:=True, _
        FieldInfo:=Array(Array(1, 2), Array(2, 1))
End Sub
VB
  • ポイント:
    • 型指定: 品番や郵便番号は「文字列」で桁落ち防止。
    • クォート処理: ダブルクォート付きCSVはQueryTablesが安定。

テキスト/ログを1行ずつ読み込み（柔軟な整形向け）

Sub Import_Text_LineByLine()
    Dim p As String: p = ThisWorkbook.Path & "\log.txt"
    If Not FileExists(p) Then MsgBox "見つかりません: " & p: Exit Sub

    Dim fn As Integer, line As String, r As Long
    fn = FreeFile: Open p For Input As #fn
    r = 2
    Do Until EOF(fn)
        Line Input #fn, line
        Cells(r, 1).Value = line
        r = r + 1
    Loop
    Close #fn
End Sub
VB
  • ポイント: 自由な整形が得意。CSV仕様厳密対応が不要なログなどに最適。

ダイアログで選んで取り込み（単体・複数）

'単体選択→Excel/CSVを取り込み
Sub Import_FilePicker_Single()
    Dim sel As Variant
    sel = Application.GetOpenFilename("Excel/CSV (*.xlsx;*.xlsm;*.xls;*.csv),*.xlsx;*.xlsm;*.xls;*.csv", , "取り込むファイルを選択")
    If sel = False Then Exit Sub

    Import_SafeWrapStart

    If LCase$(Right$(sel, 4)) = ".csv" Then
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CStr(sel), Destination:=Range("A1"))
            .TextFileCommaDelimiter = True
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .Refresh BackgroundQuery:=False
        End With
    Else
        Dim wb As Workbook
        Set wb = Workbooks.Open(CStr(sel), ReadOnly:=True, UpdateLinks:=False)
        Worksheets("Import").Range("A1").Resize(1000, 4).Value = wb.Worksheets(1).Range("A1").Resize(1000, 4).Value
        wb.Close False
    End If

    Import_SafeWrapEnd
End Sub

'複数選択→順次取り込み（CSVを縦に追加する例）
Sub Import_FilePicker_MultiCsv()
    Dim fd As FileDialog, i As Long
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Title = "CSVファイルを選択"
        .Filters.Clear: .Filters.Add "CSV", "*.csv"
        If .Show <> -1 Then Exit Sub
        Import_SafeWrapStart
        Dim startRow As Long: startRow = 2
        For i = 1 To .SelectedItems.Count
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & .SelectedItems(i), Destination:=Cells(startRow, 1))
                .TextFileCommaDelimiter = True
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .Refresh BackgroundQuery:=False
            End With
            startRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 '次の追記位置へ
        Next
        Import_SafeWrapEnd
    End With
End Sub
VB
  • ポイント:
    • 単体/複数選択: 現場運用が楽。
    • 追記位置更新: 取り込むたびに次の行へ。

フォルダから一括取り込み（最新ファイル・全ファイル）

'1) 最新CSVだけ取り込む（名前に日付が含まれる想定）
Sub Import_LatestCsvInFolder()
    Dim dirPath As String: dirPath = ThisWorkbook.Path & "\Input\"
    Dim name As String, latest As String, latestDate As Date

    name = Dir(dirPath & "*.csv")
    Do While name <> ""
        Dim d As Date
        On Error Resume Next
        d = DateValue(Mid$(name, InStrRev(name, "_") + 1, 8)) '例: name_yyyymmdd.csv
        On Error GoTo 0
        If d > latestDate Then latestDate = d: latest = name
        name = Dir()
    Loop
    If latest = "" Then MsgBox "CSVがありません": Exit Sub

    Import_SafeWrapStart
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dirPath & latest, Destination:=Range("A1"))
        .TextFileCommaDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .Refresh BackgroundQuery:=False
    End With
    Import_SafeWrapEnd
End Sub

'2) フォルダ内のExcel全ファイルの先頭シートを連結
Sub Import_AllExcelInFolder()
    Dim dirPath As String: dirPath = ThisWorkbook.Path & "\Input\"
    Dim name As String: name = Dir(dirPath & "*.xlsx")
    Dim outRow As Long: outRow = 2

    Import_SafeWrapStart
    Do While name <> ""
        Dim wb As Workbook
        Set wb = Workbooks.Open(dirPath & name, ReadOnly:=True, UpdateLinks:=False)
        Dim src As Range: Set src = wb.Worksheets(1).Range("A1").CurrentRegion
        Worksheets("Import").Cells(outRow, 1).Resize(src.Rows.Count, src.Columns.Count).Value = src.Value
        outRow = outRow + src.Rows.Count
        wb.Close False
        name = Dir()
    Loop
    Import_SafeWrapEnd
End Sub
VB
  • ポイント:
    • 最新判定: ファイル名規約に合わせて抽出。
    • 連結: CurrentRegionで範囲を取り、下へ追記。

よくある落とし穴と対策

  • 型崩れ（先頭ゼロ/勝手な日付変換）:
    • 対策: 取り込み時に列型を「文字列」に指定。必要な列だけ後で型変換。
  • 文字化け（UTF-8/SJIS混在）:
    • 対策: QueryTablesの文字コード指定がない場合、事前にUTF-8→SJIS変換か、ADODB.Streamで読み込んで貼る方法へ切り替える。
  • リンク更新で遅い/固まる:
    • 対策: Workbooks.Openは UpdateLinks:=False。必要時のみ更新。
  • イベント暴発・再計算負荷:
    • 対策: 安全ラップで EnableEvents=False、Calculation=Manual を徹底。
  • Dir列挙中の状態リセット:
    • 対策: 列挙ループ中に別のDirを呼ばない。列挙は1ループで完結。
  • 取り込み先の行詰まり:
    • 対策: 追記位置は Cells(Rows.Count, 1).End(xlUp).Row + 1 で確実に更新。

例題セット

'例1：1ファイル選択→CSVならQueryTables、Excelなら範囲コピー
'→ Import_FilePicker_Single をそのまま使用

'例2：フォルダ内のCSVを全部取り込み（縦に連結）
Sub Example_ImportAllCsv()
    Dim dirPath As String: dirPath = ThisWorkbook.Path & "\Input\"
    Dim name As String: name = Dir(dirPath & "*.csv")
    Dim startRow As Long: startRow = 2
    Import_SafeWrapStart
    Do While name <> ""
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dirPath & name, Destination:=Cells(startRow, 1))
            .TextFileCommaDelimiter = True
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .Refresh BackgroundQuery:=False
        End With
        startRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        name = Dir()
    Loop
    Import_SafeWrapEnd
End Sub

'例3：ログ（txt）を行抽出して取り込み（ERRORだけ）
Sub Example_ImportLogErrors()
    Dim p As String: p = ThisWorkbook.Path & "\app.log"
    If Not FileExists(p) Then MsgBox "見つかりません: " & p: Exit Sub
    Dim fn As Integer, line As String, r As Long
    fn = FreeFile: Open p For Input As #fn
    r = 2
    Do Until EOF(fn)
        Line Input #fn, line
        If InStr(line, "ERROR") > 0 Then
            Cells(r, 1).Value = line
            r = r + 1
        End If
    Loop
    Close #fn
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました