Looping and Offset
My current dataset is 4 columns by 10 rows in sheet1.
I need to copy each record 11 times into sheet2.
Field headings are the same on both€¦
Heres what Ive been tripping over:

Sub Test()
Dim myRange As Range
Dim ro As Integer
Dim co As Integer
Dim aa, xx, bb As Integer
Dim varA As String

Set myRange = ActiveSheet.Range("A1").CurrentRegion
ro = myRange.Rows.Count
co = myRange.Columns.Count
Set ther = Worksheets("Sheet2").Range("A2")
For aa = 2 To ro
For x = 1 To 11
For bb = 1 To co
varA = Worksheets("Sheet1").Cells(aa, bb).Value
' MsgBox "Row: " & aa & Chr(13) & Chr(13) & "Data: " & varA
ther.Value = varA
' Offset does not work properly
Set ther = ther.Offset(0, bb)
' MsgBox ther.Address
Next bb
Next x
' Pointer needs to drop down one row
Next aa
End Sub


Appreciatively!
Arturo

Sub Test()
Dim myRange As Range
Dim ro As Integer
Dim co As Integer
Dim aa, xx, bb As Integer
Dim varA As String

Set myRange = Worksheets("Sheet1") _
.Range("A1").CurrentRegion
ro = myRange.Rows.Count
co = myRange.Columns.Count
Set ther = Worksheets("Sheet2").Range("A2")
For aa = 2 To ro
For x = 1 To 11
For bb = 1 To co
varA = Worksheets("Sheet1").Cells(aa, bb).Value
ther.Offset(aa - 2, bb - 1).Value = varA
Next bb
Next x
' Pointer needs to drop down one row
Next aa
End Sub

--
Regards,
Tom Ogilvy


--
Regards,
Tom Ogilvy


"Arturo" wrote in message
...
Looping and Offset
My current dataset is 4 columns by 10 rows in sheet1.
I need to copy each record 11 times into sheet2.
Field headings are the same on both.
Here's what I've been tripping over:

Sub Test()
Dim myRange As Range
Dim ro As Integer
Dim co As Integer
Dim aa, xx, bb As Integer
Dim varA As String

Set myRange = ActiveSheet.Range("A1").CurrentRegion
ro = myRange.Rows.Count
co = myRange.Columns.Count
Set ther = Worksheets("Sheet2").Range("A2")
For aa = 2 To ro
For x = 1 To 11
For bb = 1 To co
varA = Worksheets("Sheet1").Cells(aa, bb).Value
' MsgBox "Row: " & aa & Chr(13) & Chr(13) & "Data: " & varA
ther.Value = varA
' Offset does not work properly
Set ther = ther.Offset(0, bb)
' MsgBox ther.Address
Next bb
Next x
' Pointer needs to drop down one row
Next aa
End Sub


Appreciatively!
Arturo

There may be no need for any loops at all. Let's say you have 100 records.

I'm not quite sure where you want the 11 copies to go.

If you want to copy the entire set of records at once, so the 1st copy of
record #1 is at row 2, the 2nd copy at 202, 3rd at 302, etc. we just copy the
whole group of 100 records and paste to a range that is 100 * 11 rows high and
10 columns wide. Excel will duplicate the 100 source rows to fill the
destination, just as it would if you did this manually on a worksheet. See
Test1.

OTOH, if you want the 11 copies of the 1st record in rows 2:12, then the 11
copies of the 2nd record in rows 13:23, etc, you do need a loop, but just one
loop. You copy an entire row (10 columns) and paste to a range that is 11 rows
high and 10 columns wide. Excel will create the 11 copies for you. See Test2.
You use a For/Next loop to keep track of the source row and a 2nd variable to
keep track of the destination row. The latter is incremented by 11 on each
pass through the loop.

Option Explicit

Sub Test1()
Dim NumRows As Long
Dim WKS1 As Worksheet
Dim WKS2 As Worksheet

Const NumColumns As Long = 10
Const NumCopies As Long = 11

Application.ScreenUpdating = False

Set WKS1 = Worksheets("Sheet1")
Set WKS2 = Worksheets("Sheet2")

With WKS1
NumRows = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
.Range("A2").Resize(NumRows, NumColumns).Copy
End With

With WKS2
.Paste .Range("A2").Resize(NumRows * NumCopies, NumColumns)
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Sub Test2()
Dim DestRow As Long
Dim SrcRow As Long
Dim WKS1 As Worksheet
Dim WKS2 As Worksheet

Const NumColumns As Long = 10
Const NumCopies As Long = 11

Application.ScreenUpdating = False

Set WKS1 = Worksheets("Sheet1")
Set WKS2 = Worksheets("Sheet2")

DestRow = 2

For SrcRow = 2 To WKS1.Cells(WKS1.Rows.Count, 1).End(xlUp).Row
WKS1.Cells(SrcRow, 1).Resize(1, NumColumns).Copy
WKS2.Paste _
Destination:=WKS2.Cells(DestRow, 1).Resize(NumCopies, NumColumns)
DestRow = DestRow + Numcopies
Next SrcRow

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

On Tue, 16 Nov 2004 16:13:01 -0800, Arturo
wrote:

Looping and Offset
My current dataset is 4 columns by 10 rows in sheet1.
I need to copy each record 11 times into sheet2.
Field headings are the same on both…
Here’s what I’ve been tripping over:

Sub Test()
Dim myRange As Range
Dim ro As Integer
Dim co As Integer
Dim aa, xx, bb As Integer
Dim varA As String

Set myRange = ActiveSheet.Range("A1").CurrentRegion
ro = myRange.Rows.Count
co = myRange.Columns.Count
Set ther = Worksheets("Sheet2").Range("A2")
For aa = 2 To ro
For x = 1 To 11
For bb = 1 To co
varA = Worksheets("Sheet1").Cells(aa, bb).Value
' MsgBox "Row: " & aa & Chr(13) & Chr(13) & "Data: " & varA
ther.Value = varA
' Offset does not work properly
Set ther = ther.Offset(0, bb)
' MsgBox ther.Address
Next bb
Next x
' Pointer needs to drop down one row
Next aa
End Sub


Appreciatively!
Arturo