how to resolve vba code with copy from another file-CodePudding

In one file I have data (Zeszyt.xlsm - Sheet1) and in the other an empty file (Sheet2) with the same headers and fill in button. However, when I press the button. There is no mistake but nothing complements. Could you help me ?

Private Sub CommandButton2_Click()

Dim wb As Workbook
ThisWorkbook.Worksheets("Sheet1").Rows(12).Copy
Selection.Copy

Set wb = Workbooks.Open("C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm")
wb.Worksheets("Sheet2").Activate

lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow   1, 1).Select

ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savehanges = True

Set wb = Nothing

ThisWorkbook.Worksheets("Sheet1").Activate
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select

Application.CutCopyMode = False

End Sub

CodePudding user response：

There is no need to select or copy/paste.

First of all I would propose to put all parameters like workbook names etc. as constants to the header of the module. By that it is much easier to fix renamings etc.

By having a generic copyRangeValues-routine you can re-use this sub for other copy-actions as well:

Option Explicit

'config source
Private Const wsSourceName As String = "Sheet1"
Private Const rowToCopy As Long = 12    'is this really always row 12????

Private Const wbTargetName As String = "C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm"
Private Const wsTargetName As String = "Sheet2"



Private Sub CommandButton2_Click()

'First step: prepare your source range
Dim wbSource As Workbook
Set wbSource = ThisWorkbook

Dim wsSource As Worksheet
Set wsSource = wbSource.Worksheets(wsSourceName)

Dim rgSource As Range
Set rgSource = wsSource.Rows(rowToCopy)


'second step: prepare your top left target cell
Dim wbTarget As Workbook
Set wbTarget = Workbooks.Open(wbTargetName)

Dim wsTarget As Worksheet
Set wsTarget = wbTarget.Worksheets(wsTargetName)

Dim lastRow As Long
lastRow = wsTarget.UsedRange.Rows.Count

Dim rgTargetCell As Range
Set rgTargetCell = wsTarget.Cells(lastRow   1, 1)


'third step: copy range - use generic routine
copyRangeValues rgSource, rgTargetCell

'fourth step: close target workbook
wbTarget.Close saveChanges:=True

End Sub


'Put this in a general module
Public Sub copyRangeValues(rgSource As Range, rgTargetCell As Range)
'generic routine to copy one range to another
'rgTargetCell = top left corner of target range

Dim rgTarget As Range
'resize rgTarget according to dimensions of rgSource
With rgSource
    Set rgTarget = rgTargetCell.Resize(.Rows.Count, .Columns.Count)
End With


'write values from rgSource to rgTarget - no copy/paste necessary!!!
'formats are not copied - only values
rgTarget.Value = rgSource.Value

End Sub

CodePudding user response：

Copy Row To Another File

The code will run slower if you use Activate and Select. but not if you use variables.

Option Explicit

Private Sub CommandButton2_Click()
 
    Const swsName As String = "Sheet1"
    Const sRow As Long = 12
    
    Const dFilePath As String _
        = "C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm"
    Const dwsName As String = "Sheet2"
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
    Dim srg As Range: Set srg = sws.Rows(sRow)
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
    Dim dCell As Range
    Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    
    srg.Copy Destination:=dCell
    
    dwb.Close SaveChanges:=True
 
    Application.ScreenUpdating = True
 
    MsgBox "Done.", vbInformation, "Append Row"

End Sub