macro to select certain columns in every 5th row of data

[dogztar]

Hello,

I'm trying to help an associate develop what I believe will be a (fairly) simple Excel macro, but I have ~0 experience with Excel macro programming (surprise, bet you don't get that often). Anyway, assuming the data occupies about 15 columns, we want to extract say columns 1-3,10, and 13, from every 5th row. Tried doing this with Analysis Toolkit's Sampling method, but it only works with numeric data. Data size is ~2000 rows. Note nothing fancy is required here, just selecting the information and copying it so it can be pasted into another sheet.

Thanks in advance for any input.

Kyle

 

[Legacy 98055]

Just wanted to be sure what you needed...
If you have 30 rows of data. this is the data you want extracted...

Row 5 Col 1 to 3,10,13
Row 10 Col 1 to 3,10,13
Row 15 Col 1 to 3,10,13
Row 20 Col 1 to 3,10,13
Row 25 Col 1 to 3,10,13
Row 30 Col 1 to 3,10,13

Would it be ok if the macro sent the data to a blank sheet...for the above example:

First 6 rows, first 5 columns on new sheet.

Thanks,
Tom

 

[Legacy 98055]

Hi
This will copy your chosen columns on every 5th row beginning at the row you choose, to sheet2 from sheet1.

Sub SelectiveCopy()
Dim S As Long, P As Long
Dim C As Long

S = 5 ' or whichever row you will be starting
P = 0

For C = S To 10000 Step 5
P = P + 1
If Range("A" & C) = "" Then Exit Sub
Sheet2.Range("A" & P) = Range("A" & C)
Sheet2.Range("B" & P) = Range("B" & C)
Sheet2.Range("C" & P) = Range("C" & C)
Sheet2.Range("J" & P) = Range("J" & C)
Sheet2.Range("M" & P) = Range("M" & C)
Next
End Sub

Tom

 

[Yogi Anand]

Hi Kyle:
I know you asked for a macro solution and TsTom has provided one, however you may also want to refer to a non-macro solution at ...

http://www.mrexcel.com/board/viewtopic.php?topic=5776&forum=2

 

[Ivan F Moala]

Hi Kyle

Not to take away from TSTOM or Yogi
you could try/test this macro...which is a
little more dynamic.....

To place it in your workbook;

1) Press Alt F11 (VBA Editor)
2) Press Ctrl R (Project explorer)
3) Right click on one of the Objects in the
explorer...from the ensuing options select
Insert Module
4) Copy the code below and paste into this
Module.
5) Go back to your worksheet and before
running it save a backup copy JIC.
6) Now try running the macro
Tools > Macro > run OR
if you have the macro tollbar just click
Run


<pre/>
Sub Test_Extract()
Dim Every As Single
Dim St As Range
Dim rRgToCopy As String
Dim x As Double
Dim sRgCopy As String

'Given columns to copy => 1-3,10,13

Every = Application.InputBox("Type in number of every other Row to Copy", Default:=5, Type:=1)
If Every = 0 Then GoTo UserCancelled

Again:
On Error Resume Next
Set St = Application.InputBox("Type in number of rows to skip", Type:=8)
If Err Then GoTo UserCancelled
Err.Clear

If St.Rows.Count > 1 Or St.Columns.Count > 1 Then
MsgBox "Must be single cell selection"
GoTo Again
End If

sRgCopy = "A" & St.Row & ":C" & St.Row & ",J" & St.Row & ",K" & St.Row & ":O" & St.Row

'// Now Copy
Do While Range(St.Address).Offset(Every * x, 0) <> ""
Range(sRgCopy).Offset(Every * x, 0).Copy Sheets("Sheet2").Cells(x + 1, 1)
x = x + 1
Loop

UserCancelled:

End Sub
</pre>

 

[memicol]

Here's another way using a different approach.
Assumes that row 1 on Sheet1 is a header row and you want to copy Sheet1 rows 2,7,12,etc. (columns 1:3,10,13) to Sheet2. Also, the data is pasted below any data that may already exist on Sheet2.

Sub Test_Extract2()
Dim rng As Range
Application.ScreenUpdating = False
With Sheets("Sheet2")
.[A:B,E:F].Insert
.[F:K].Insert
End With
Sheets("Sheet1").Select
[A:B].Insert
Set rng = Range([C1], [C65536].End(xlUp))
With [A1]
.Value = 1
.AutoFill Destination:=rng.Offset(0, -2), Type:=xlFillSeries
End With
With rng.Offset(0, -1)
.FormulaR1C1 = "=IF(MOD(ROW()-2,5)=0,1,"""")"
.Value = .Value
.EntireRow.Sort Key1:=[B1]
.SpecialCells(xlCellTypeConstants, 1).EntireRow.Copy Sheets("Sheet2").[C65536].End(xlUp)(2, -1)
.EntireRow.Sort Key1:=[A1]
End With
[A:B].Delete
Sheets("Sheet2").[A:B,F:K,M:N].Delete
End Sub

 

[dogztar]

Wow, quite a variety of ideas...very interesting. I did post this question on another board (www.experts-exchange.com) and got a fairly straightforward answer:

Option Explicit

Public Sub CopySpecificRanges()
Dim i As Integer
Dim j As Integer
i = 5
j = 2
While i <= 15
With Worksheets(1)
.Activate
.Range("A" & i & ",B" & i & ",C" & i & ",J" & i & ",M" & i).Select
Selection.Copy
End With
With Worksheets(2)
.Activate
.Range("A" & j).Select
.Paste
End With
j = j + 1
i = i + 5
Wend

End Sub
---------------
This worked just fine, but thank you all for your input and for showing me there are many many ways to do this.

-Kyle

 

[Jay Petrulis]

Hi,

Ivan's answer is much better, in my opinion, but this is a nice solution. It can be made much better by removing the unnecessary .Select and .Activate lines

-----------------------
Public Sub CopySpecificRanges()
Dim i As Integer
Dim j As Integer
i = 5
j = 2
While i <= 15
Worksheets(1).Range("A" & i & ",B" & i & ",C" & i & ",J" & i & ",M" & i).Copy _
Worksheets(2).Range("A" & j)
j = j + 1
i = i + 5
Wend

End Sub
---------------------------

 

[fdrl]

On 2002-04-25 15:10, Jay Petrulis wrote:
Hi,

Ivan's answer is much better, in my opinion, but this is a nice solution. It can be made much better by removing the unnecessary .Select and .Activate lines

-----------------------
Public Sub CopySpecificRanges()
Dim i As Integer
Dim j As Integer
i = 5
j = 2
While i <= 15
Worksheets(1).Range("A" & i & ",B" & i & ",C" & i & ",J" & i & ",M" & i).Copy _
Worksheets(2).Range("A" & j)
j = j + 1
i = i + 5
Wend

End Sub
---------------------------

Just out of interest, I adjusted the three suggested macros (Ivan's, yours, and Memicol's) so that they all do the same thing and then checked the run times.

For only 15 rows of data to process (as in your posted example) Ivan's & yours were instantaneous while Memicol's took about 1 second.

However, to process 25000 rows, the run times were :-

Ivan 9-10 seconds
Yours 8-9 seconds
Memicol 4-5 seconds

 

[Jay Petrulis]

Hi,

Nice job testing this. Memicol's solution works quite nicely.

No doubt the solutions work. I did not post an answer, merely improved on one that was offered away from the MrExcel board.

I apologize if it came across that I was detracting from the responses. I just liked the flexibility in Ivan's suggestion.

My "issue" with the one answer is that it could easily have been made to run cleaner. Whomever wrote it knows how to write code, so should've been aware of the "no-no's."

In the end, they all work, so whatever the OP likes is OK by me.

Regards,
Jay