Looping through folder and copying csv with a certain name into active workbook-CodePudding

I am trying to loop through a folder containing different csv files and copying the ones with the prefix AB. However, my loop gets stuck on the second file it finds and copies and pastes it continuously. Does anyone find where this could be happening?


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

CodePudding user response：

Your issue is While Dir(abfilepath) <> "" - this resets the file search every time.

Instead, your loop should look like so:

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

    'do stuff with file

    filefound=Dir 'looks for next file
Wend

CodePudding user response：

Import Data From Closed Workbooks To Existing Worksheets

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