The code below allows to copy the values from the selected row of a sheet ("Registos") to another sheet ("Resultados"), within the same workbook ("Livro1.xls").
So, each time I select the row, it is copied to the sheet, always to the next row of that sheet.
Works perfectly as I could test.
Here is the code:
Private Sub Copiar_Click()
'Copy selected rows to the sheet "Resultados" in this workbook.
Dim SourceRange As Range
Dim DestRange As Range
Dim Lr As Long
Lr = LastRow(Sheets("Resultados")) + 1
Set SourceRange = Sheets("Registos").Cells( _
ActiveCell.Row, 1).Range("D1:Y1")
With SourceRange
Set DestRange = Sheets("Resultados").Range("D" _
& Lr).Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
I would like to know, and for that I need help, is doing the same, but copying selected rows to the sheet ("Resultados"), but in another workbook (Livro2.xls).
I've tried several ways but it does not work as in the previous example.
I have the following code that opens and closes the other workbook (Livro2.xls), but this always copies the same row.
This is the code I have:
Private Sub Copiar2_Click()
'Copy selected rows to the sheet "Resultados" in workbook ("Livro2.xls")
Dim SourceRange As Range
Dim DestRange As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim Lr As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Change the file name (2*) and the path/file name to your file
If bIsBookOpen_RB("Livro2.xls") Then
Set DestWB = Workbooks("Livro2.xls")
Else
Set DestWB = Workbooks.Open("C:\Users\Antonio Gralhas\Desktop\Teste\Livro2.xls")
End If
'Change the Source Sheet and range
Set SourceRange = Range("D1:Y1")
'Change the sheet name of the database workbook
Set DestSh = DestWB.Worksheets("Resultados")
Lr = LastRow(DestSh)
Set DestRange = DestSh.Range("D" & Lr + 1)
'We make DestRange the same size as SourceRange and use the Value
'property to give DestRange the same values
With SourceRange
Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
End With
DestRange.Value = SourceRange.Value
DestWB.Close savechanges:=True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function bIsBookOpen_RB(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen_RB = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
I would be most grateful if someone could help me to solve this problem, because I need the code to finish the work I'm developing.
Bellow are the attached file to your appreciation.
Thank you for all
Reply With Quote
