Excel Macro Data Extraction

[BIGALINWALES]

Hey,

I need to extract some data from an excel sheet into anothe sheet. All of the data is in column A, starts at Row 17 is 5 rows long and repeats every 58 rows.

Example
17 |
18 |
19 |
20 |
21 |
.
.58 Rows
.
75 |
76 |
77 |
78 |
79 |
.
.58 Rows
.
etc.etc

So I need a macro that start at Row 17, reads 5 Rows down, copies this data to another sheet then moves down to the next set of data 58 rows down (from the original row not the original row plus the 5)
If anyone could help I would really appreciate it.

Many Thanks

Alex

PS This is my effort so far, but I'm crap at VB so can't get any further

Dim i As Integer
Dim j As Integer
i = 17
j = 1
Dim ii As String
Dim iii As String

Do
ii = "A" & i
iii = "A" & (i + 5)

Range("ii:iii&quot.Select
Selection.Copy
i = i + 58
Sheets("Sheet1&quot.Select
Range("j&quot.Select
j = j + 5
ActiveSheet.Paste
Range("j&quot.Select
Sheets("Year End address P60 test produ&quot.Select
Loop Until i = 46567

End Sub

 

[xlbo]

BIGALISBACK ;-)
Sumting like this should see you straight:

Sub GetEm()
dim sht1 as worksheet, sht as worksheet, lRow as long
set sht1 = sheets("Sheet1&quot
set sht2 = sheets("Sheet2&quot
lRow = sht1.range("A65536&quot.end(xlup).row
x=1
For i = 17 to lRow step 58
with sht1
.range(cells(i,1),cells(i+5,1)).copy destination:=sht2.cells(x,1)
x=x+5
next i
end sub

watch for word wrap on the copy / destination line - it should all be on one line

Rgds
Geoff
"Some cause happiness wherever they go; others whenever they go."
-Oscar Wilde

 

[Zathras]

Here is one way:
[blue]

Option Explicit

Sub CopySpecial()
Dim rng As Range
Dim sht As Worksheet
Dim nRow As Long

  Set sht = Worksheets("Sheet2")
  Worksheets("Sheet1").Activate
  nRow = 1
  Set rng = Range("A17:A21")
  While rng.Cells(1, 1).Text <> &quot;&quot;
    rng.Copy Destination:=sht.Cells(nRow, 1)
    nRow = nRow + 5
    Set rng = rng.Offset(58, 0)
  Wend
  Set sht = Nothing
  Set rng = Nothing
End Sub

[/color]

 

[Loomah]

hi
This (I think) will do what you're after but you could consider filtering the list

Sub it()
Dim lRow As Long
Dim lCount As Long
Dim i As Integer
lCount = 1
lRow = 17
Do While Not IsEmpty(Worksheets(1).Cells(lRow, 1))
    For i = 0 To 4
        Worksheets(2).Cells(lCount + i, 1).Value = Worksheets(1).Cells(lRow + i, 1).Value
    Next
    lCount = lCount + 5
    lRow = lRow + 58
Loop
End Sub

or this one's just recorded

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 07/05/2003
'

'
    Columns("A:A").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:=&quot;<>&quot;
    Range(&quot;A17&quot;).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets(&quot;Sheet3&quot;).Select
    Range(&quot;A1&quot;).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

;-)

If a man says something and there are no women there to hear him, is he still wrong?

 

[Loomah]

Amazing!
Four solutions (now 5) from three people!!

Taking my recorded effort (definately ignore the written one as xlbo & zathras' will be more efficient) if the 58 rows and the first 17 are empty how about this

Sub a()
With Worksheets(1)
    .Columns(&quot;A:A&quot;).AutoFilter Field:=1, Criteria1:=&quot;<>&quot;
    .Range(Cells(17, 1), Cells(17, 1).End(xlDown)).SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(3).Range(&quot;A1&quot;)
    .Columns(&quot;A:A&quot;).AutoFilter
End With
End Sub

?
;-)


If a man says something and there are no women there to hear him, is he still wrong?

 

[BIGALINWALES]

WOW, what an amazing response! looks like I'm back with BIG effect xlbo ;-) I shall try these out in the morning and let you know how i get on. Thanks again for all the help, it will have saved someone a lot of tedious cutting and pasting!!.

Cheers

Alex