VBA将文件名中的行添加到单元格中答案

【问题标题】：VBA add rows from filename into cellsVBA将文件名中的行添加到单元格中
【发布时间】：2016-10-27 23:33:46
【问题描述】：

我对堆栈进行了研究，但无法准确找到我需要的内容或足够接近来编辑代码。我对 VBA 很陌生。

我在一个目录中有一堆（> 100 个文件）.csv 文件。文件名与此格式一致：customer_id-inventory_id.forecast.csv。

例如：12345678-111111.forecast.csv； 12345-222.forecast.csv； ...等

这些文件只有两列日期和预测。我想将文件名中的 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

这不会生成任何文件名。

【问题讨论】：

您想为所有 csv 自动执行此操作，对吗？或者您只想在文件的子集上运行该宏？顺便说一句，处理文件名信息的总是C 和D 列？
@RCaetano。是的，希望它自动将 .csv 文件名提取到相应的文件中。我也在运行宏/vba。
@RCaetano 是的，只有 C 和 D。所有的文件内容格式都是一样的。
所提供的解决方案是否对您有用或您需要更多帮助？
@Rcaetano 还不确定。我正在运行测试，但我不断收到错误，因此试图修复它。

标签： vba excel csv

【解决方案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

【讨论】：

谢谢！！！！尝试运行此程序但出现以下错误：运行时错误'-2147467259 (80004005) 自动化错误未指定错误。 Ran ODBC 驱动程序必须匹配 32 没有帮助。正在努力修复自动化错误。
这可能会有所帮助：请参阅：stackoverflow.com/questions/13811179/…
该错误似乎是您尝试从中运行它的工作簿尚未保存。确保将其保存到 CSV 所在的目录中。

【解决方案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 ;)

【讨论】：