Копировать определенные строки из рабочей книги в x количество новых рабочих книг (по одной на строку), вставляя только в формате / значениях

Question

Новичок в VBA.Что я пытаюсь сделать:

• Скопируйте первые 5 строк _ строку 'x' в текущем листе и вставьте в новую книгу
• Новые книги должны быть сохранены втот же каталог
• Это должно повторяться для каждой строки ниже первых 5, то есть строк 1-5 + 6, строк 1-5 + 7, строк 1-5 + 8 и т. д.
• Когдавставляя строки в новую книгу, я не хочу копировать формулы, просто форматировать и значения

Это то, что у меня есть:

Sub CommandButton1_Click()

    Dim MyBook As Workbook, newBook As Workbook
    Dim FileNm As String

    Set MyBook = ThisWorkbook

    FileNm = ThisWorkbook.Path & "\" & "TEST-BOOK.xlsx"
    Set newBook = Workbooks.Add

    With newBook
        MyBook.Sheets("Sheet1").Rows("1:5").Copy .Sheets("Sheet1").Rows("1")

        'Save new wb
        .SaveAs Filename:=FileNm, CreateBackup:=False

        .Close Savechanges:=False
    End With

End Sub

Он копируетстроки 1-5, но я не знаю, как добавить динамическую дополнительную строку - он также копирует все формулы и встраивает их.Предполагая, что имя файла также должно быть в каком-то цикле?Спасибо.

Answer 1

надеюсь, это поможет,

Sub CommandButton1_Click()

    Dim wb As Workbook, FileNm As String, LastRow As Long, Headers As Range, wbTemp As Workbook, i As Long

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

    Set wb = ThisWorkbook

    'lets suppose your data is in the first worksheet of your book
    With wb
        LastRow = .Sheets(1).Cells(.Sheets(1).Rows.Count, 1).End(xlUp).Row - 5 'this is to count how many rows you've got
        Set Headers = .Sheets(1).Rows("1:5") 'set the headers to copy them every iteration
    End With

    'copy each row + headers in a new workbook
    For i = 1 To LastRow
        FileNm = wb.Path & "\" & "TEST-BOOK" & i & ".xlsx" 'add the i to number every workbook from 1 to extra rows you have
        Set wbTemp = Workbooks.Add 'add a new workbook
        Headers.Copy 
        wbTemp.Sheets(1).Rows(1).PasteSpecial xlPasteValues 'paste the headers
        wb.Sheets(1).Rows(5 + i).Copy 
        wbTemp.Sheets(1).Rows(6).PasteSpecial xlPasteValues 'copy the next row in the iteration
        wbTemp.SaveAs FileNm
        wbTemp.Close
        Set wbTemp = Nothing
    Next i

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub