VBA； 将包含CSV文件的文件夹导出到一个Excel文件中

Question

我有一个包含.csv文件的文件夹，但我正在尝试将文件中的所有数据导入到一个Excel工作表中。 另外，我试图水平组织我的数据，它只会复制一次变量，然后再复制数据。

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

Answer 1

代码已修改

1. xSht声明为工作表
2. 禁用On Error
3. 根据您的选择，可能会或可能不会禁用屏幕更新，计算等
4. 目标列必须在Do循环中计算。 从Msgbox分支中删除，并合并到侧面Do循环中。
5. CSV文件的工作表名称可能并不总是“ Sheet1”。 使用Sheets(1)或ActiveSheet`
6. Sheets("")吗？ 已删除。 直接使用声明的xSht
7. 无法理解在Do while中使用And xSht.Name并删除了它。

发现工作到目前为止了解。

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