Move some data to new workbook - my attempted macro is no good

Hi-

I want to move columns of data between two workbooks as listed below.

Source file = "source_life06.xls" ; Destination file = "paste.xls"

Source --> Destination
D --> P
E --> Q
F --> F
K --> L
Y --> I

Based on past help I've rcvd in this forum, I pieced together the macro below. For some reason, it only results in one hit--seems not to loop through all the rows. Can anyone show me what I did wrong? or suggest a better approach? Thanks!

Sub Macro1()
Dim rng1 As Range, cell As Range
Dim bk1 As Workbook, bk2 As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Set bk1 = Workbooks("source_life06.xls")
Set bk2 = Workbooks("paste.xls")
Set sh1 = bk1.Worksheets(1)
Set sh2 = bk2.Worksheets(1)
Set rng1 = sh1.Range(sh1.Cells(2, 1), sh1.Cells(2, 1).End(xlDown))

Dim pgStart, pgEnd As Integer
Dim title, pointer, contentNo As String

For Each cell In rng1

rw = 2

sh1.Activate
ActiveSheet.Range("A2").Select

'Get page start
pgStart = ActiveCell.Offset(0, 3).Value

'Get page end
pgEnd = ActiveCell.Offset(0, 4).Value

'Get title
title = ActiveCell.Offset(0, 5).Value

'Get pointer
pointer = ActiveCell.Offset(0, 10).Value

'Get content number
contentNo = ActiveCell.Offset(0, 24).Value

sh2.Cells(rw, 16).Value = pgStart
sh2.Cells(rw, 17).Value = pgEnd
sh2.Cells(rw, 6).Value = title
sh2.Cells(rw, 12).Value = pointer
sh2.Cells(rw, 9).Value = contentNo

Next

sh2.Activate
ActiveSheet.Range("A1").Select
End Sub

Hi Marlea

Two things that stand out. The first is that you are looping for each
Cell in the range but always setting your variables based on the
activecell - which is not changing so

pgStart = ActiveCell.Offset(0, 3).Value
should be
pgStart = Cell.Offset(0, 3).Value

and
pgEnd = ActiveCell.Offset(0, 4).Value
should be
pgEnd = Cell.Offset(0, 4).Value
etc

Secondly you never increase the value of rw so every paste will be into
the same row of the target workbook. You need to add 1 to rw each time
you loop eg:

> <snip>
> sh2.Cells(rw, 9).Value = contentNo
> rw = rw + 1
> Next
> <snip>

Hope this helps
Rowan

marlea wrote:
> Hi-
>
> I want to move columns of data between two workbooks as listed below.
>
> Source file = "source_life06.xls" ; Destination file = "paste.xls"
>
> Source --> Destination
> D --> P
> E --> Q
> F --> F
> K --> L
> Y --> I
>
> Based on past help I've rcvd in this forum, I pieced together the macro
> below. For some reason, it only results in one hit--seems not to loop
> through all the rows. Can anyone show me what I did wrong? or suggest a
> better approach? Thanks!
>
> Sub Macro1()
> Dim rng1 As Range, cell As Range
> Dim bk1 As Workbook, bk2 As Workbook
> Dim sh1 As Worksheet, sh2 As Worksheet
> Set bk1 = Workbooks("source_life06.xls")
> Set bk2 = Workbooks("paste.xls")
> Set sh1 = bk1.Worksheets(1)
> Set sh2 = bk2.Worksheets(1)
> Set rng1 = sh1.Range(sh1.Cells(2, 1), sh1.Cells(2, 1).End(xlDown))
>
> Dim pgStart, pgEnd As Integer
> Dim title, pointer, contentNo As String
>
> For Each cell In rng1
>
> rw = 2
>
> sh1.Activate
> ActiveSheet.Range("A2").Select
>
> 'Get page start
> pgStart = ActiveCell.Offset(0, 3).Value
>
> 'Get page end
> pgEnd = ActiveCell.Offset(0, 4).Value
>
> 'Get title
> title = ActiveCell.Offset(0, 5).Value
>
> 'Get pointer
> pointer = ActiveCell.Offset(0, 10).Value
>
> 'Get content number
> contentNo = ActiveCell.Offset(0, 24).Value
>
> sh2.Cells(rw, 16).Value = pgStart
> sh2.Cells(rw, 17).Value = pgEnd
> sh2.Cells(rw, 6).Value = title
> sh2.Cells(rw, 12).Value = pointer
> sh2.Cells(rw, 9).Value = contentNo
>
> Next
>
> sh2.Activate
> ActiveSheet.Range("A1").Select
> End Sub
>
>

Thanks, Rowan! It's working now, yay!

You're welcome.

marlea wrote:
> Thanks, Rowan! It's working now, yay!
>
>