Question

我有一个要在其中将数据从当前Excel文件复制和粘贴到目标Excel文件的要求。

下面是我的代码：

Sub ImportCSV()
    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long

    Application.ScreenUpdating = False

    'Change the path to the source folder accordingly
    'strSourcePath = "C:\Path\"
    strSourcePath = Application.ActiveWorkbook.Path

    If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
    'Change the path to the destination folder accordingly
    strDestPath = Application.ActiveWorkbook.Path
    If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
            strFile = Dir(strSourcePath & "*.csv")

    Set newbook = Workbooks.Add
    With newbook
        .SaveAs Filename:=strDestPath + "ERNTable.xlsx"
        .Close
    End With

    Do While Len(strFile) > 0
        Cnt = Cnt + 1
        If Cnt = 1 Then
           r = 1
       Else
           r = Cells(Rows.Count, "A").End(xlUp).Row + 1
       End If
       Open strSourcePath & strFile For Input As #1
       If Cnt > 1 Then
           Line Input #1, strData
       End If
       Do Until EOF(1)
           Line Input #1, strData
           x = Split(strData, ",")
           For c = 0 To UBound(x)
               Cells(r, c + 1).Value = Trim(x(c))
           Next c
           r = r + 1
           Loop
       Close #1
       Name strSourcePath & strFile As strDestPath & strFile
       strFile = Dir
   Loop
   Set newBook = workbooks.add
   with newBook
       .saveas filename:= "Finalfile.xlsx"
   End with

   ActiveSheet.Range("B$1:c$" &r).copy workbooks("Finalfile.xlsx").Worksheets("Sheet1").Range(("B$1:c$" &r)
   Workbooks("Finalfile.xlsx").Save
   Application.ScreenUpdating = True

   If Cnt = 0 Then _
       MsgBox "No CSV files were found...", vbExclamation
   End If
End Sub

Answer 1

如我所见，您正在尝试将单个CSV导入到新工作簿中，如果是这种情况，则不需要太多代码...

但是，如果您需要循环浏览多个CSV并将其添加到不同/相同的电子表格中，则需要对现有代码或以下代码进行一些修改。

这适用于1：1复制/粘贴。

Sub ImportCSV()

    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim sourceWB As Workbook, targetWB As Workbook
    Dim lastRow As Long

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    strFile = "CSV FILE NAME.csv"

    'Change the path to the source folder accordingly
    'strSourcePath = "C:\Path\"
    strSourcePath = Application.ActiveWorkbook.Path
    If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"

    'Change the path to the destination folder accordingly
    strDestPath = Application.ActiveWorkbook.Path
    If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"

    'Open the CSV
    Set sourceWB = Workbooks.Open(strSourcePath & strFile)
    lastRow = sourceWB.Sheets(1).Cells(sourceWB.Sheets(1).Rows.Count, "B").End(xlUp).Row

    'Create new workbook
    Set targetWB = Workbooks.Add

    'Add the data to the new workbook
    targetWB.Sheets("Sheet1").Range("B1:C" & lastRow) = sourceWB.Sheets(1).Range("B1:C" & lastRow).Value

    'Save the new workbook
    targetWB.SaveAs Filename:=strDestPath + "Finalfile.xlsx"

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

使用VBA将数据从当前Excel文件获取到另一个Excel文件

1 个答案: