对文件夹中的所有文件执行 VBA 宏

Posted 2023-02-19

【中文标题】对文件夹中的所有文件执行 VBA 宏

【英文标题】：Execute VBA Macro on all Files in a Folder

【发布时间】：2021-12-19 14:07:53

【问题描述】：

我有大量设置相同的 .csv 文档。它们都是 .csv，因此都需要简单的格式。我的目标很简单：

将它们从 .csv 格式化为常规列（例如，Excel 中的 TextToColumns） 将每个单独文件中的数据提取到一个 Excel 工作表中以供进一步分析

我在 VBA 中尝试了很多方法来循环使用宏的文件夹，但我还没有成功。事实上，没有一个宏做任何改变（？） 我希望有人能帮帮忙。我的尝试之一如下所示。

最好， 卡尔

Dim filename As Variant
Dim a As Integer
a = 1

filename = Dir("/Users/karlemilthulstrup/Downloads/Test med kun 1Vp/Files*.csv")

Do While filename <> ""
Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
        DecimalSeparator:=".", ThousandsSeparator:=",", TrailingMinusNumbers:= _
        True

Loop

End Sub

编辑： OPs Eureka! 来自 cmets 的代码：

Sub test6()
    Dim filename As Variant
    Dim a As Integer
    Dim MyFiles As String
    a = 1
    filename = Dir("/Users/karlemilthulstrup/Downloads/Test med kun 1Vp/Files.csv")
    Do While filename <> ""
        Workbooks.Open MyFiles
        ActiveWorkbook.Close SaveChanges:=True
        filename = Dir
    Loop
End Sub

【问题讨论】：

你必须实际打开文件。

为了选择一些东西，你应该打开文件，然后使用Dir() 使循环继续......你是尝试在csv文件上做些什么还是先复制现有工作簿中的数据?如果修改它，应该保存并关闭它，然后再处理下一个。无论如何，选择无济于事。它只消耗 Excel 资源，并没有带来任何好处。

如果不打开文件，您将永远不会对其进行任何更改：查看：application.workbooks.add

Power Query 对此很有用。数据 > 获取数据 > 从文件 > 从文件夹

如果您使用 VBA 路由，请将您的工作簿设置为一个变量 - Set WrkBk = Workbooks.Open(filename) 和 WrkBk.Worksheets("Sheet1").Columns("A:A").TextToColumns..... 和 WrkBk.Close SaveChanges:=True。我不会依赖 ActiveWorkbook 是正确的工作簿。必填链接：how-to-avoid-using-select-in-excel-vba

【参考方案1】：

如果您需要将 csv 文件导入 Excel 范围，请在“Do While..”循环中使用如下所示的 Sub 而不是“Workbook.Open”

'' transfer a csv file data to Excel at start of Cell range specified
Public Sub ImportCSV2Excel(csvFilePath As String, atCell As Range)
    Dim Fso As Object, txtFile As Object
    Dim LineTxt As Variant, i As Long
    Set Fso = VBA.CreateObject("Scripting.FileSystemObject")

    Set txtFile = Fso.OpenTextFile(Filename:=csvFilePath, IOMode:=1, Create:=False) ''IOMode Enum (ForReading=1, ForWriting=2, ForAppending=8)
    atCell.CurrentRegion.Clear
    While Not txtFile.atEndofstream
        LineTxt = VBA.Split(txtFile.readline, ",")
        i = i + 1
        atCell.Cells(i, 1).Resize(1, UBound(LineTxt) + 1).Value = LineTxt
    Wend
    txtFile.Close
    Set txtFile = Nothing

End Sub

Sub test_Importcsv()
    ImportCSV2Excel "E:/sales.csv", Sheet1.Range("A1")
End Sub

【参考方案2】：

从CSV 导入

Option Explicit

Sub ImportData()
    Const ProcTitle As String = "Import Data"
    
    Const sSubPath As String = "/Downloads/Test med kun 1Vp/Files/"
    Const sFilePattern As String = "*.csv"
    
    Dim sPath As String: sPath = Environ("USERPROFILE") & sSubPath
    
    Dim sfName As String: sfName = Dir(sPath & sFilePattern)
    If Len(fName) = 0 Then
        MsgBox "No files found in '" & sPath & "'.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    'Application.ScreenUpdating = False ' uncomment when you got it right
    
    Do Until Len(sfName) = 0
        Dim swb As Workbook
        Set swb = Workbooks.Open(Filename:=sPath & sfName)
        ' When opening the workbook there are many parameters you can use.
        ' When a 'csv' opens with all the data in one column, I most often
        ' just need to set the `Local` argument to `True` i.e.:
        'Set swb = Workbooks.Open(Filename:=sPath & sfName, Local:=True)
        ' Note that there is also the 'Delimiter' argument which you could
        ' modify to get the workbook open 'properly'. Also, there is
        ' the 'Workbooks.OpenText method'. Using `TextToColumns` should be
        ' your last 'resort'.
        Dim sws As Worksheet: Set sws = swb.Worksheets(1) ' only one per 'csv'
        sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
        swb.Close SaveChanges:=False
        sfName = Dir
    Loop
    
    'dwb.save
    
    'Application.ScreenUpdating = True ' uncomment when you got it right
    
    MsgBox "Data imported.", vbInformation, ProcTitle
        
End Sub

【讨论】：

非常感谢！我的常量和选择目录有问题，因为我不断收到错误消息：“在'XX'中找不到文件”。您提供的代码是否需要某种语法？

Files是文件夹还是每个文件的起始字符串？如果是后者，那么这就是问题所在。 Environ 适合我，也许不适合你。在做任何事情之前，你必须找到正确的路径。

啊，我知道为什么了。我正在尝试在 MacOS 上执行代码，而 Environ 显然不可用。我会尝试自己调整代码。再次感谢您