Add a new workbook and paste the data in the continuous sheet-CodePudding

I have a worksheet (sheet2) which contains a vlookup function with changing values in certain cells to refresh data. I want to copy any changed values to paste into a new workbook.

Sub Copy_file()
    Dim xWs As Worksheet
    Dim Rng As Range
    Set Rng = Range("C6:M124")
    Application.Workbooks.Add
    Set xWs = Application.ActiveSheet
    Rng.Copy
    xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteValues
    xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
    xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
    xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    
End Sub

So, the above code actually runs fine. But every time a macro runs, it always creates a new workbook over and over again.

I need to modify it so that I can add a new workbook with a specific name and the copied data is pasted in sheet1 only when the macro runs for the first time. Then the copied data will be pasted in the next sheet (eg Sheet2, sheet3, sheet4,... etc.) in the single workbook.

CodePudding user response：

Try:

Sub Copy_file()
    Application.ScreenUpdating = False
    Dim xWs As Worksheet
    Static WB As Workbook  ' static variables stores its values between proc calls
    
    If WB Is Nothing Then   ' check if a certain workbook exists. if no, create it
        Set WB = Workbooks.Add
    Else
        WB.Worksheets.Add after:=WB.Sheets(WB.Sheets.Count) ' create the next WS
    End If
    Set xWs = ActiveSheet
   
    ThisWorkbook.Sheets("Sheet2").Range("C6:M124").Copy
    With xWs.Cells(2, 2)
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    End With
    Application.ScreenUpdating = True
End Sub

CodePudding user response：

Please, try the next code:

Sub Copy_file()
    Dim xWs As Worksheet, Rng As Range, wb As Workbook, wsMark As Worksheet
    Dim wbFullName As String, wbName As String, lastR As Long
    
    wbName = "MyWorkbook.xlsx"
    wbFullName = ThisWorkbook.Path & "\" & wbName
    
    Set Rng = Range("C6:M124") 'the range is set in the active workbook
                               'if the one keeping the code, please state it
                               'and the range will be fully qualified
    If dir(wbName) = "" Then 'if the necessary workbook does not exist
        Set wb = Application.Workbooks.Add 'create it
        wb.saveas wbName                   'name the newly created workbook
        Set wsMark = wb.Sheets(wb.Sheets.count)
        wsMark.Name = "UsedSheets"         'name the last sheet keeping copying order
    End If
    If wb Is Nothing Then                  'if not created above, but exists:
        On Error Resume Next
         Set wb = Workbooks(wbName)        'check if it is open
         Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
        On Error GoTo 0
    End If
    'if not open, open it:
    If wb Is Nothing Then
        Set wb = Workbooks.Open(wbFullName)
        Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
    End If
    lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
    If lastR > 1 Then
        If CLng(wsMark.Range("A" & lastR).value) < (wb.Sheets.count - 2) Then
            Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value   1))
            wsMark.Range("A" & lastR   1).value = xWs.Index
        Else
            Set xWs = wb.Sheets.Add(Before:=wsMark)
            wsMark.Range("A" & lastR   1).value = xWs.Index
        End If
    Else
         Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR   1).value = 1
    End If
    Rng.copy
    With xWs.cells(2, 2)
       .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                   SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                   SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
   End With
End Sub