Copy specific cells to new rows
Try the following code. Note: If Sheet2 is empty, it will copy to row 2,
however.
Public Sub CopyCells()
Dim wb As Workbook
Dim ws1 As Worksheet 'Source worksheet for data to copy.
Dim ws2 As Worksheet 'Destination worksheet.
Dim rngName As Range 'Named ranges.
Dim rngDate As Range
Dim rngCompany As Range
Dim rngState As Range
Dim lngNextAvailableRow As Long
Set wb = ActiveWorkbook
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
With wb
Set rngName = .Names("Name").RefersToRange
Set rngDate = .Names("Date").RefersToRange
Set rngCompany = .Names("Company").RefersToRange
Set rngState = .Names("State").RefersToRange
End With
With ws2
With .UsedRange
lngNextAvailableRow = .Row + .Rows.Count
End With
'Now copy cells.
.Cells(lngNextAvailableRow, 1).Value = rngName.Value
.Cells(lngNextAvailableRow, 2).Value = rngDate.Value
.Cells(lngNextAvailableRow, 3).Value = rngCompany.Value
.Cells(lngNextAvailableRow, 4).Value = rngState.Value
End With
End Sub
--
Regards,
Bill Renaud
|