简体   繁体   中英

VBA; exporting folder with CSV files into one excel file

I have a folder with .csv files but I am trying to import all the data from the files into one excel sheet. Also, I am trying to organize my data horizontally, and the it will only copy the variables once, and then just the data afterwards.

Sub ImportCSVsWithReferenceI()
'UpdatebyKutoolsforExcel20151214
    'Dim xSht As Worksheet
    Dim xSht As Workbook
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xCount As Long
    On Error GoTo ErrHandler


    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet

    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then
        xSht.UsedRange.Clear
        xCount = 1
    Else
        xCount = xSht.Cells(3, Columns.Count).End(xlToLeft).Column + 1
    End If

    'Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.csv")

    Do While xFile <> "" And xSht.Name
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        xWb.Sheets("Sheet1").Columns(2).Copy xSht.Sheets("").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
        'Rows(1).Insert xlShiftDown
        'Range("B1") = ActiveSheet.Name
        'ActiveSheet.UsedRange.Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
        'ActiveSheet.Columns(2).Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

        xWb.Close False
        xFile = Dir
        'xCount = xSht.Cells(3, Columns.Count).End(xlToLeft).Column + 1
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no files csv", , "Kutools for Excel"
End Sub

Code modified

  1. xSht declared as As Worksheet
  2. disabled use of On Error
  3. May or may not disable Screen updating, calculations etc as per your choice
  4. Destination Column must be calculated in side the Do loop. Deleted from Msgbox branch and incorporated in side Do loop.
  5. CSV file Sheet name may not be always "Sheet1". Use either Sheets(1) or ActiveSheet`
  6. Sheets("") ? deleted. Directly use xSht as declared
  7. Failed to understand use of And xSht.Name in Do while and deleted.

Found working as far understood.

Sub ImportCSVsWithReferenceI()
'UpdatebyKutoolsforExcel20151214
    Dim xSht As Worksheet
    'Dim xSht As Workbook
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xCount As Long
    Dim xOffset As Integer
  ' On Error GoTo ErrHandler


    With Application
  '      .Calculation = xlCalculationManual
  '      .EnableEvents = False
  '      .ScreenUpdating = False
    End With


    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet

    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then
        xSht.UsedRange.Clear
    End If

    'Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.csv")

    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        xOffset = IIf(IsEmpty(xSht.Cells(1, Columns.Count).End(xlToLeft)), 0, 1)
        xWb.Sheets(1).Columns(2).Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(, xOffset)
        'Rows(1).Insert xlShiftDown
        'Range("B1") = ActiveSheet.Name
        'ActiveSheet.UsedRange.Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
        'ActiveSheet.Columns(2).Copy xSht.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

        xWb.Close False
        xFile = Dir
    Loop
    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