Error Checking in Excel
Thanks Thanks:  0
Likes Likes:  0
Results 1 to 10 of 10

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

  1. #1
    New Member
    Join Date
    Apr 2002
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  2. #2
    Board Regular
    Join Date
    Mar 2002
    Location
    Cincinnati, Ohio, USA
    Posts
    6,824
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  3. #3
    Board Regular
    Join Date
    Mar 2002
    Location
    Cincinnati, Ohio, USA
    Posts
    6,824
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  4. #4
    MrExcel MVP
    Join Date
    Mar 2002
    Location
    Michigan USA
    Posts
    11,454
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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/viewtop...c=5776&forum=2
    Regards!

    Yogi Anand, D.Eng, P.E.
    Energy Efficient Building Network LLC
    www.energyefficientbuild.com

  5. #5
    MrExcel MVP Ivan F Moala's Avatar
    Join Date
    Feb 2002
    Location
    Auckland, New Zealand
    Posts
    4,209
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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



    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



    Kind Regards,
    Ivan F Moala From the City of Sails

  6. #6

    Join Date
    Apr 2002
    Posts
    16
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  7. #7
    New Member
    Join Date
    Apr 2002
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  8. #8
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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
    ---------------------------

  9. #9

    Join Date
    Apr 2002
    Posts
    12
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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




  10. #10
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •