Question

我正在尝试从用户选择的CSV的第二行开始复制。

如何调整代码，以便：

1）每个CSV的数据均粘贴在“数据”标签中，但每个CSV均从第2行开始。

这样做的原因是因为已经有一个标题行。

下面是代码：

Sub ImportCSVsWithReference3()

    Dim xSht  As Worksheet
    Dim xSht2 As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim LstRw As Long, Rng As Range

    Set xSht2 = Sheets("DATA")

    Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    xFileDialog.AllowMultiSelect = True
    xFileDialog.Title = "Select a folder [CSV Consolidation]"

    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) = vbYes Then xSht2.UsedRange.Clear
    Application.ScreenUpdating = False

    Dim vrtSelectedItem As Variant

     Set xWb = Workbooks.Open(xStrPath)
     MsgBox "Opened " & xStrPath & " for headers"

     Range("A1:R1").Copy

     'Do your work with headers here with xWb as workbook with code
     xWb.Close False

     xSht2.Activate
     Range("A1") = "File Name"
     Range("B1").Select
     ActiveSheet.Paste

    Application.CutCopyMode = False

    For Each vrtSelectedItem In xFileDialog.SelectedItems

        Set xWb = Workbooks.Open(vrtSelectedItem)
        MsgBox "Opened " & vrtSelectedItem & " for content"
        'Do your work with content here with xWb as workbook with code

        Columns(1).Insert xlShiftToRight
        Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
        LstRw = ActiveSheet.Range("A2" & ActiveSheet.Rows.Count).End(xlUp).Row


        ActiveSheet.LstRw.Copy xSht2.Range("A" & Rows.Count).End(xlUp).Offset(1)


        xWb.Close False
    Next

    Application.ScreenUpdating = True

End Sub

Answer 1

您可以执行以下操作：

i = 0
For Each vrtSelectedItem In xFileDialog.SelectedItems
    i = i + 1
    Set xWb = Workbooks.Open(vrtSelectedItem)
    Debug.Print "Opened " & vrtSelectedItem
    With xWb.Sheets(1)
        .Columns(1).Insert xlShiftToRight
        .Range("A1").Resize(.UsedRange.Rows.Count, 1).Value = .Name
        Set rngCopy = .Range("A1").CurrentRegion
        If i > 1 Then Set rngCopy = rngCopy.Offset(1, 0) 'only content if not first file
    End With
    rngCopy.Copy xSht2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    xWb.Close False
Next

Answer 2

根据我的测试，请尝试以下代码：

Sub ImportCSVsWithReference3()
    Dim xSht  As Worksheet
    Dim xSht2 As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim LstRw As Long, Rng As Range
    Dim vrtSelectedItem As Variant
    Dim i As Integer
    Set xSht2 = Sheets("DATA")
    Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    xFileDialog.AllowMultiSelect = True
    xFileDialog.Title = "Select a folder [CSV Consolidation]"
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) = vbYes Then xSht2.UsedRange.Clear
Application.ScreenUpdating = False
    Set xWb = Workbooks.Open(xStrPath)
    MsgBox "Opened " & xStrPath & " for headers"
    Range("A1:R1").Copy
    xWb.Close False
    xSht2.Activate
    Range("A1") = "File Name"
    Range("B1").Select
    ActiveSheet.Paste
Application.CutCopyMode = False
For Each vrtSelectedItem In xFileDialog.SelectedItems
    i = i + 1
    Set xWb = Workbooks.Open(vrtSelectedItem)
    xWb.Sheets(1).Columns(1).Insert xlShiftToRight
    Set region = xWb.Sheets(1).Range("A1").CurrentRegion
    If i > 1 Then Set region = region.Offset(1, 0)
    region.Copy xSht2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    xWb.Close False
Next
Application.ScreenUpdating = True
End Sub

VBA复制从每个CSV的第二行开始

2 个答案: