遍历文件夹并将具有特定名称的 csv 复制到活动工作簿中

Question

我正在尝试遍历包含不同 csv 文件的文件夹并复制前缀为 AB 的文件。 但是，我的循环卡在它找到的第二个文件上，并不断复制和粘贴它。 有没有人发现这可能发生在哪里？

Do Until Dir(filepath & "*") = ""
    
    ' defining path and file names
    abfilename = Dir(filepath & "AB" & "*")
    
    abfilepath = filepath & "AB" & "*"

' if pathname doesnt return files then quit and clear contents
    If Len(abfilename) = 0 Then
    
        ' ThisWorkbook.Sheets("AB_*").Range("A:Z").ClearContents
    
        MsgBox "The data folder has no SW files"
        
        Exit Sub
        
    ' AB files found and copied
    ElseIf abfilename <> "" Then
        
        MsgBox "File Found"
        ' iterate while there are files with SW prefix
        While Dir(abfilepath) <> ""
        
        ' Copying into worksheet
            Dim ws As Worksheet, csv As Workbook, cCount As Long, cName As String
            
            
            abfilename_stripped = Replace(abfilename, ".csv", "")
            
            
            Set ws = ThisWorkbook.Sheets(abfilename_stripped)
            
            Workbooks.Open abfilepath, Local:=True    ' Open the csv
            MsgBox abfilename
            Set csv = ActiveWorkbook    ' Create object of csv workbook
            csv.ActiveSheet.Range("A:Z").Copy  ' Copy all cells
            
            MsgBox "File Copied"
            
            ws.Activate                 ' Go back to pasting sheet
            ws.Range("A1").PasteSpecial xlPasteValues 'Pasting Values
            
            MsgBox "File Pasted"
            csv.Close                   ' Closing open csv
            
            Set csv = Nothing
            swfilename = Dir()
            
            
        Wend
        
    
        
    End If

Answer 1

您的问题是While Dir(abfilepath) <> "" - 这每次都会重置文件搜索。

相反，您的循环应该如下所示：

filefound=Dir(abfilepath)
While filefound<>"" Then

    'do stuff with file

    filefound=Dir 'looks for next file
Wend

Answer 2

将数据从关闭的工作簿导入到现有工作表

Option Explicit

Sub ImportData()

    Const SRC_FOLDER_PATH As String = "C:\Test"
    Const SRC_FILE_PATTERN As String = "AB*.csv"
    Const SRC_COPY_COLUMNS As String = "A:Z"
    Const DST_FIRST_CELL As String = "A1"
    
    Dim pSep As String: pSep = Application.PathSeparator

    Dim sFolderPath As String
    sFolderPath = SRC_FOLDER_PATH & IIf(Right(SRC_FOLDER_PATH, 1) = pSep, "", pSep)

    Dim sFileName As String: sFileName = Dir(sFolderPath & SRC_FILE_PATTERN)
    If Len(sFileName) = 0 Then
        MsgBox "No files matching """ & SRC_FILE_PATTERN & """ in """ _
            & sFolderPath & """ found.", vbCritical
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    Dim ColumnsCount As Long ' is always the same;...
    ColumnsCount = dwb.Worksheets(1).Columns(SRC_COPY_COLUMNS).Columns.Count
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, sFilePath As String
    Dim dws As Worksheet, drg As Range, dfCell As Range, dName As String
    Dim RowsCount As Long ' ...may (will) be different
    
    Do While Len(sFileName) > 0
        
        ' The source file base name, the name without the file extension,
        ' becomes the destination worksheet name.
        dName = Left(sFileName, InStrRev(sFileName, ".") - 1)
        
        On Error Resume Next
            Set dws = dwb.Sheets(dName)
        On Error GoTo 0
        
        If Not dws Is Nothing Then ' destination sheet exists
            
            sFilePath = sFolderPath & sFileName

            Set swb = Workbooks.Open(Filename:=sFilePath, Local:=True)
            Set sws = swb.Sheets(1) ' the one and only ('.csv')
            
            With sws.UsedRange.EntireRow ' restrict to the last...
                RowsCount = .Row + .Rows.Count - 1 ' ... row of the used range
                Set srg = sws.Columns(SRC_COPY_COLUMNS).Resize(RowsCount)
            End With
            
            Set dfCell = dws.Range(DST_FIRST_CELL)
            ' The destination range needs to be of the same size
            ' as the source range...
            Set drg = dfCell.Resize(RowsCount, ColumnsCount)
            
            ' ... to be able to copy like this:
            drg.Value = srg.Value ' the most efficient way to copy values
             
            drg.Resize(dws.Rows.Count - drg.Row - RowsCount + 1) _
                .Offset(RowsCount).ClearContents ' clear below
             
            swb.Close SaveChanges:=False ' it was just read (copied) from
            
            Set dws = Nothing ' reset for the next iteration
        
        'Else ' destination sheet doesn't exist; do nothing!?
        
        End If
            
        sFileName = Dir ' next source file (workbook) name
    
    Loop
        
    Application.ScreenUpdating = True
    
    MsgBox "Data imported.", vbInformation

End Sub