Copy specific cells to new rows
 

I am looking for some help copying some specific cells from one worksheet to
the last row on another sheet. Basically I have various which I have named.
I want to a macro that will take these cells and paste them to a new row.
For example on Sheet one I may have the following Named cells

C2 = Name
D3 = Date
C4 = Company
E6 = State

I then want a macro to past these in the last available row, sequentially in
each column starting in column A. For example, assuming the last available
row is 20, the Sheet1.C2 would copy to Sheet2A20, Sheet1.D3 to Sheet2.B20,
Sheet1.C4 TO Sheet2.C20 and sheet1.E6 to Sheet2.D20.

Any help would be greatly appreciated.

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