简体   繁体   中英

VBA Import all .csv files from a folder won't work

I'm trying to create a macro in excel that will import.csv files from different folders into individual sheets. The code I'm using is copied from another workbook where it imports a table like A2:M10 but when I tried adapting it to this new workbook (which will import single row csv files) it compiles and runs but doesn't import anything

Sub Missing_Tools_Import()

    Dim xSht As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String

    On Error GoTo ErrHandler
    
    xStrPath = "O:\Process Engineering\Missing Tools\CV2"

    If xStrPath = "" Then Exit Sub
        Worksheets("CV2").Activate
        Set xSht = ThisWorkbook.ActiveSheet
        xSht.UsedRange.Clear
            Application.ScreenUpdating = False
            xFile = Dir(xStrPath & "\" & "*.csv")
            Do While xFile <> ""
            Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
            Columns(1).Insert xlShiftToRight
            Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
            ActiveSheet.UsedRange.Copy xSht.Range("A1:L1").End(xlUp).Offset(1)
            xWb.Close False
            xFile = Dir

        Loop
        Application.ScreenUpdating = True

xStrPath = "O:\Process Engineering\Missing Tools\CV Tower"

    If xStrPath = "" Then Exit Sub
        Worksheets("CV Tower").Activate
        Set xSht = ThisWorkbook.ActiveSheet
        xSht.UsedRange.Clear
            Application.ScreenUpdating = False
            xFile = Dir(xStrPath & "\" & "*.csv")
            Do While xFile <> ""
            Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
            Columns(1).Insert xlShiftToRight
            Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
            ActiveSheet.UsedRange.Copy xSht.Range("A1:L1").End(xlUp).Offset(1)
            xWb.Close False
            xFile = Dir

        Loop
        Application.ScreenUpdating = True

...


    Exit Sub


ErrHandler:
MsgBox "no files csv", , "Kutools for Excel"
End Sub

It repeats for 6 different sheets but none of them work.

I've played with small changes in the code with nothing happening. Most of this code I found online to begin with so I don't have a strong grasp on how it works.

xSht is the active sheet so the copy is to itself. Qualify the ranges to the relevant workbook.

Option Explicit
Sub Missing_Tools_Import()

    Dim xSht As Worksheet, xWb As Workbook
    Dim xFileDialog As FileDialog, f, r As Long
    Dim xStrPath As String, xFile As String
    
    Application.ScreenUpdating = False
    For Each f In Array("CV2", "CV Tower")
    
        xStrPath = "O:\Process Engineering\Missing Tools\" & f
    
        Set xSht = ThisWorkbook.Worksheets(f)
        xSht.UsedRange.Clear
        r = 1
    
        xFile = Dir(xStrPath & "\" & "*.csv")
        Do While xFile <> ""
        
            Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
            With xWb.Sheets(1)

                .Columns(1).Insert xlShiftToRight
                .Columns(1).SpecialCells(xlBlanks).Value = .Name
                .UsedRange.Copy xSht.Cells(r, "A")
                r = r + .UsedRange.Rows.Count
                
            End With
            xWb.Close False
            xFile = Dir

        Loop
    Next
    Application.ScreenUpdating = True

End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM