Copy data from one sheet to another

[Slim Slender]

Here's my challenge.
Copy the contents of cells B3, D3, G3, B6, D6, G6 on Sheet1 to the
first empty row on Sheet2, then,
if there is something in B7, D7, G7, copy B3, D3, G3, B7, D7, G7 to
the next empty row on Sheet 2, and
if there is something in B8, D8, G8, copy B3, D3, G3, B8, D8, G8, etc.

 

[OssieMac]

Need to know if you want the data copied to the corresponding columns on
sheet2 or if you want it copied to the first 6 columns.

 

[Slim Slender]

Need to know if you want thedatacopied to the corresponding columns on
sheet2 or if you want it copied to the first 6 columns.

--
Regards,

OssieMac





- Show quoted text -

Copy into the first 6 columns to create record in a database.
Where it says etc means there are 5 more examples for a total of 8,
and not an indefinite number. Note that B3, D3, and G3 are repeated.
Thanks

 

[OssieMac]

Hi Slim,

I am not sure it you mean any ONE of the cells B7, D7 or G7 must have data
or if you mean that they ALL must have data. Therefore I have given you 2
options. (See the comments at the top of the code). The only difference is
the Loop While line of code.

I had to separate the copy of B3, D3, G3 and B6, D6 and G6 etc otherwise
they pasted one under the other instead of on the same line.

If you don't have column headers in sheet2 then it will leave one blank row
at the top. If you have coumn headers on sheet2 then it will not leave any
blank rows.

Note that a space and underscore at the end of a line is a line break in an
otherwise single line of code. I use them in these posts to alleviate
problems of the lines breaking where they shouldn't.

Sub CopyData()
'This code copies if any ONE of the
'cells B7, D7 or G7 etc has a value
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rngToCopy As Range
Dim r As Long 'Row number

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

r = 6 'Start row

With ws1
Do
Union(.Cells(3, "B"), _
.Cells(3, "D"), _
.Cells(3, "G")).Copy _
Destination:=ws2.Cells _
(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0)

Union(.Cells(r, "B"), _
.Cells(r, "D"), _
.Cells(r, "G")).Copy _
Destination:=ws2.Cells _
(.Rows.Count, "A") _
.End(xlUp).Offset(0, 3)

r = r + 1
Loop While .Cells(r, "B") <> "" _
Or .Cells(r, "D") <> "" _
Or .Cells(r, "G") <> ""

End With

End Sub

'End of first example
'**********************************

Sub CopyData2()
'This code copies if ALL of the
'cells B7, D7 and G7 etc have a value.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rngToCopy As Range
Dim r As Long 'Row number

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

r = 6 'Start row

With ws1
Do
Union(.Cells(3, "B"), _
.Cells(3, "D"), _
.Cells(3, "G")).Copy _
Destination:=ws2.Cells _
(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0)

Union(.Cells(r, "B"), _
.Cells(r, "D"), _
.Cells(r, "G")).Copy _
Destination:=ws2.Cells _
(.Rows.Count, "A") _
.End(xlUp).Offset(0, 3)

r = r + 1
Loop While .Cells(r, "B") <> "" _
And .Cells(r, "D") <> "" _
And .Cells(r, "G") <> ""

End With

End Sub

 

[Slim Slender]

Thanks Ossie, that works nicely.