Получить данные из текущего файла Excel в другой файл Excel с помощью VBA

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