VBAはファイル名からセルに行を追加します

Question

私はスタックを研究しましたが、私が必要とするものを正確に見つけることができず、コードを編集するのに十分なほど近くにありませんでした。私はVBAにはかなり新しいです。

ディレクトリに.csvファイルの束（> 100ファイル）があります。ファイル名は、customer_id-inventory_id.forecast.csvの形式と一貫しています。

例：12345678-111111.forecast.csv; 12345-222.forecast.csv; ...など

これらのファイルには、日付と予測の列が2つしかありません。私は各ファイルのこれらのセルにファイル名からcustomer_idとinventory_idを持ち込みたいと思います。元のファイルをご覧ください：

12345678-111111.forecast.csv;

12345-222.forecast.csv;

出力ファイルCUSTOMER_IDとinventory_dにもたらしました。これをVBAでどのように書くのですか？ありがとう！

12345678-111111.forecast.csv;

12345-222.forecast.csv;

は、私が試した：VBA - Excel Append Every Active Row With File Name

Dim LastRow As Long 
Dim LastColumn As Long 
Sub InsertFileName() 
    Application.ScreenUpdating = False 
    Dim i As Long 
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row 
    For i = 1 To LastRow 
    LastColumn = ActiveSheet.Cells(i,  ActiveSheet.Columns.Count).End(xlToLeft).Column 
    ActiveSheet.Cells(i, LastColumn + 1) = "=CELL(""filename"")" 
    Next i 
    Application.ScreenUpdating = True 
End Sub 

これは任意のファイル名を生成されていません。

Answer 1

これは、ワークブックがすべてのCSVと同じディレクトリにあることを前提としています。

Sub Consolidate() 

    Dim sSQL  As String  'SQL String 
    Dim oCn   As Object  'Connection 
    Dim oRs   As Object  'Recordset 
    Dim vFile  As Variant  'File Name 
    Dim sCustomer As String  'Customer ID 
    Dim sItem  As String  'Inventory Item ID 

' Get filenames 
    vFile = Dir(ThisWorkbook.Path & "\*.csv") 

' Create SQL 
    While vFile <> vbNullString 
     If sSQL <> vbNullString Then sSQL = sSQL & vbCr & "Union " & vbCr 
     sCustomer = Split(vFile, "-")(0) 
     sItem = Split(Split(vFile, "-")(1), ".")(0) 
     sSQL = sSQL & "Select '" & sCustomer & "' as Customer, '" & sItem & "' as Item, * from [" & vFile & "]" 
     vFile = Dir 
     DoEvents 
    Wend 
' Create Connection Objects 
    Set oCn = CreateObject("ADODB.Connection") 
    Set oRs = CreateObject("ADODB.Recordset") 

    oCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
      "Data Source=" & ThisWorkbook.Path & ";" & _ 
      "Extended Properties=""Text;HDR=YES;FMT = CSVDelimited"";" 
    oRs.Open sSQL, oCn 
    Debug.Print sSQL 

    If Sheet1.ListObjects.Count > 0 Then Sheet1.ListObjects(1).Delete 
    Sheet1.ListObjects.Add(_ 
     SourceType:=xlSrcQuery, _ 
     Source:=oRs, _ 
     Destination:=Sheet1.Range("C6")).QueryTable.Refresh 

    oRs.Close 
    oCn.Close 

    Set oRs = Nothing 
    Set oCn = Nothing 

End Sub 

Answer 2

注：このマクロを実行する前に、あなたは間違って行く場合何かであなたのCSVファイルのバックアップを作成する必要があります。そして、多分このコードはあなたを助けることができる：

Option Explicit 

Sub LoopCsvFiles() 

    Dim wb As Workbook 
    Dim ws_name As String 
    Dim file As Variant 
    Dim aux_var As Variant 

    ' Disabling alerts and screen updates 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    ' csv_folder that contains your csv files 
    file = Dir("C:\csv_folder\") 
    While (file <> "") 
     If InStr(file, ".csv") > 0 Then 

      ' Obtaining the first part of the filename 
      aux_var = Split(file, ".") 
      ' Obtaining the customer_id and the inventory_id 
      aux_var = Split(aux_var(0), "-") 

      ' Setting the workbook and sheetname 
      Set wb = Workbooks.Open(file) 
      ws_name = Replace(file, ".csv", "") 

      ' Writting data 
      wb.Worksheets(ws_name).Range("C1") = "customer_id" 
      wb.Worksheets(ws_name).Range("C2") = aux_var(0) 
      wb.Worksheets(ws_name).Range("D1") = "inventory_id" 
      wb.Worksheets(ws_name).Range("D2") = aux_var(1) 

      ' Exiting 
      wb.Save 
      wb.Close 

     End If 
     file = Dir 
    Wend 

    ' Restoring alerts and screen updates 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    MsgBox "Done!" 

End Sub 

HTH;）