Copy data from one sheet to another while skipping blanks and certain rows

[tlc1980]

Hi. I'm trying to copy data from one sheet to another, but I want it to skip blanks and a row that has data on it.

I want C9:C12, C14:C17, C19:C22, C24:C27, and C29:C34 from Sheet1 to be moved to A8:A33 on Sheet 2.

Rows 13, 18, 23, and 28 on Sheet1 need to be left out.

Thank you in advance for your help!

 

[AlphaFrog]

Maybe something like this...

[color=darkblue]Sub[/color] Copy_Stuff()
    [color=darkblue]Dim[/color] rng [color=darkblue]As[/color] Range, lRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    Application.ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] rng [color=darkblue]In[/color] Sheets("Sheet1").Range("C9:C12, C14:C17, C19:C22, C24:C27, C29:C34").Areas
        rng.Copy
        Sheets("Sheet2").Range("A8").Offset(lRow).PasteSpecial xlPasteValues
        [color=green]'rng.ClearContents      'Clear source data[/color]
        lRow = lRow + 5
    [color=darkblue]Next[/color]
    Application.CutCopyMode = [color=darkblue]True[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[tlc1980]

Hi! Thanks for replying. I tried out the code, but it's not showing up on Sheet2 how I want it to. Below is what my sheet looks like and how I want it to look like.

Sheet1		Sheet2		How I want it on Sheet2
C9	Roast Pork		A8	Roast Pork		A8	Roast Pork
C10			A9			A9	Hamburger
C11	Hamburger		A10	Hamburger		A10	Steamed Brown Rice
C12			A11			A11	Orange Glazed Sweet Potatoes
C13	M/MA: [ oz] G/WG: [0/]		A12			A12	Grapes
C14	Steamed Brown Rice		A13	Steamed Brown Rice		A13
C15			A14			A14
C16			A15			A15
C17			A16			A16
C18	M/MA: [ oz] G/WG: [0/]		A17			A17
C19			A18			A18
C20			A19			A19
C21			A20			A20
C22			A21			A21
C23	M/MA: [ oz] G/WG: [0/]		A22			A22
C24			A23			A23
C25			A24			A24
C26			A25			A25
C27			A26			A26
C28	M/MA: [ oz] G/WG: [0/]		A27			A27
C29	Orange Glazed Sweet Potatoes		A28	Orange Glazed Sweet Potatoes		A28
C30	Grapes		A29	Grapes		A29
C31			A30			A30
C32			A31			A31
C33			A32			A32
C34			A33			A33

<tbody>
</tbody>

 

[AlphaFrog]

[color=darkblue]Sub[/color] Copy_Stuff2()
    Application.ScreenUpdating = [color=darkblue]False[/color]
    Sheets("Sheet2").Range("A8:A33").ClearContents
    [color=darkblue]With[/color] Sheets("Sheet1").Range("C9:C12, C14:C17, C19:C22, C24:C27, C29:C34").SpecialCells(xlCellTypeConstants)
        .Copy
        Sheets("Sheet2").Range("A8").PasteSpecial xlPasteValues
        [color=green]'ClearContents      'Clear source data[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    Application.CutCopyMode = [color=darkblue]True[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[tlc1980]

Thank you!!!

 

[tlc1980]

Sorry, but after playing around with it some more, I can't get it to work with my data because the cells in column c are referenced from another worksheet. I have a vlookup formula in those cells. Can you please change the code a bit to get it to work with my data? Thanks!

 

[AlphaFrog]

[color=darkblue]Sub[/color] Copy_Stuff2()
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range, r [color=darkblue]As[/color] [color=darkblue]Long[/color]
    r = 8
    Application.ScreenUpdating = [color=darkblue]False[/color]
    Sheets("Sheet2").Range("A8:A33").ClearContents
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] Sheets("Sheet1").Range("C9:C12, C14:C17, C19:C22, C24:C27, C29:C34")
        [color=darkblue]If[/color] Len(cell) > 0 [color=darkblue]Then[/color]
            Sheets("Sheet2").Range("A" & r).Value = cell.Value
            r = r + 1
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] cell
    Application.ScreenUpdating = [color=darkblue]True[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[tlc1980]

Thank you again!!!

 

[aamir]

Sub Copy_Stuff1()
Dim cell As Range, r As Long
r = 2
Application.ScreenUpdating = False
Sheets("Sheet4").Range("A2:A3000").ClearContents
For Each cell In Sheets("dps").Range("AHR282:AHR388, AHT282:AHT388, AHV282:AHV388, AHX282:AHX388, AHZ282:AHZ388, AIB282:AIB388, AID282:AID388, AIF282:AIF388, AIH282:AIH388, AIJ282:AIJ388, AIL282:AIL388, AIN282:AIN388, AIP282:AIP388, AIR282:AIR388, AIT282:AIT388, AIV282:AIV388, AIX282:AIX388 ")
If Len(cell) > 0 Then
Sheets("Sheet4").Range("A" & r).Value = cell.Value
r = r + 1
End If
Next cell
Application.ScreenUpdating = True
End Sub

Sub Copy_Stuff2()
Dim cell As Range, s As Long
s = 2
Application.ScreenUpdating = False

For Each cell In Sheets("dps").Range("AIZ282:AIZ388, AJB282:AJB388, AJD282:AJD388, AJF282:AJF388, AJH282:AJH388, AJJ282:AJJ388, AJL282:AJL388, AJN282:AJN388, AJP282:AJP388, AJR282:AJR388, AJT282:AJT388, AJV282:AJV388, AJX282:AJX388, AJZ282:AJZ388, AKB282:AKB388, AKD282:AKD388, AKF282:AKF388 ")
If Len(cell) > 0 Then
Sheets("Sheet4").Range("A" & s).Value = cell.Value
s = s + 1
End If
Next cell
Application.ScreenUpdating = True
End Sub

Sub Copy_Stuff3()
Dim cell As Range, t As Long
t = 2
Application.ScreenUpdating = False

For Each cell In Sheets("dps").Range("AKH282:AKH388, AKJ282:AKJ388, AKL282:AKL388, AKN282:AKN388 ")
If Len(cell) > 0 Then
Sheets("Sheet4").Range("A" & t).Value = cell.Value
t = t + 1
End If
Next cell
Application.ScreenUpdating = True
End Sub

1st thank you for the above and cool stuff 1 works but other two not working can any help me with this

 

[AlphaFrog]

... but other two not working

"Not working" is hardly a description of the problem.
Help Us Help You

If any of the cells you want to copy have a formula that returns an error, the code (as it is now) would error on that cell. But of course, I have no idea if this is at all related to your "not working" situation.