Help Copying Certain Cells

[EB08]

<HR style="COLOR: #ffffff; BACKGROUND-COLOR: #ffffff" SIZE=1> <!-- / icon and title --><!-- message -->
I don't have access to the file right at this moment...but I will try to describe it the best I can. In Column A there is an empty cell with a gray background followed by about 5 cells of text (space between gray cells varies). I need to (if possible) be able to write something that looks for each gray cell in column A, copies the next two cells down from that gray cell, and pastes in in another sheet. That is probably the best I can do without seeing the sheet again...Any tips or advice is greatly appreciated, I'm not expecting anybody to write the code, but some pointers in the right direction would be great.

 

[erik.van.geit]

Hi,

I've tried to make a fast running code. It doesn't use any loop, so even with a large amount of data this would be fairly quick.

Option Explicit
 
Sub copy_cells()
'Erik Van Geit
'080624
'NateO pointed me to the idea
 
'PURPOSE
'copy 3 (or other amount of) cells after each grey (or any color) cell to other sheet
'EXAMPLE
'if A2 and A10 are grey, then A3:A5,A11:A13 will be copied
 
'fontcolor          24
'background color   63
'strikethrough      23
 
Const crit = 63
Const col = 1       'column to check
Const nr = 3        'number of cells to copy
Const clr = 15      'colorindex to check
 
Dim rng As Range
 
Application.ScreenUpdating = False
 
ThisWorkbook.Names.Add Name:="Color", RefersToR1C1:="=GET.CELL(" & crit & ",!RC[" & col & "])"
 
    With Worksheets(1)
    .Columns("A:B").Insert
    .Rows("1:" & nr).Insert
 
    Set rng = .Range(.Cells(1, 2), .Cells(.Cells(.Rows.Count, col + 2).End(xlUp).Row, 2))
    rng.Formula = "=Color"
 
    Set rng = .Range(.Cells(4, 1), .Cells(.Cells(.Rows.Count, col + 2).End(xlUp).Row, 1))
    rng.FormulaR1C1 = "=IF(ISNUMBER(MATCH(" & clr & ",R[-1]C[1]:R[-3]C[1],0)),1,"""")"
    .Columns(1).AutoFilter Field:=1, Criteria1:=1
 
    Set rng = .Range(.Cells(4, col + 2), .Cells(.Cells(.Rows.Count, col + 2).End(xlUp).Row, col + 2))
 
        With Sheets(2)
        .Columns("A").ClearContents
        rng.Copy .Range("A1")
        End With
 
    .Columns("A:B").Delete
    .Rows("1:" & nr).Delete
    End With    
 
ThisWorkbook.Names("Color").Delete
 
Application.ScreenUpdating = True
 
End Sub

Data will be pasted on sheet 2: change if needed

 

[EB08]

well...it works, but I sure don't understand it! My co-worker thanks you...it was quite the large list of info. Any way you could "sum up" how this whole thing works?...even understanding a few lines of this would surely help me in the long run. Much appreciated.

 

[erik.van.geit]

the best thing you can do is to step through the code using function key F8

ThisWorkbook.Names.Add Name:="Color", RefersToR1C1:="=GET.CELL(" & crit & ",!RC[" & col & "])"

This line is inserting a named range which is relative: retrieving the colorindex from the cell to the right of it.
You can check the names list after that line is done.

Then 2 columns and some rows (depending of the number of cells to copy) are inserted.
2 columns are filled with formulas
again check your sheet after those lines

You will see that column A (or another column depending of how you have set the constants) now contains blanks and "1"s.
A simple autofilter will now show only the "1"s

.Columns(1).AutoFilter Field:=1, Criteria1:=1

the rest of the code is almost plain english

advantage of this process: you can even do it manually in less then one minute (if you know how to do it )

 

[EB08]

Thanks Erik...You've been a big help. I appreciate you taking the time to put some of that into english for me!