How to create macro that conditionally copies parts of rows from a main sheet to a summary sheet.

[jduzz]

Dear all, I have only recently started with Excel and need help with what I think is a relatively easy problem:
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>a) I have a sheet1, it has many rows, in column F there is a status field (sheet1.value = ‘a’, ‘b’, ‘c’, ‘x’ or ‘y’)
b) I maintain this sheet, change whatever I want
c) When finished I want to copy a subset of sheet1 to sheet2 by pushing a button (w. a macro) in sheet1
d) When I push this button all rows in sheet1 where status is ‘x’ or ‘y’ should be copied into sheet2
e) Not the entire rows should be copied into sheet2, only the first 14 fields (the fields in column A through column M)
f) When I maintain sheet1 again, and push the button again, the data in sheet2 that I just generated must be entirely overwritten with the latest from sheet1.
<o></o>
That is really it.
I have tried this now for days but I cannot make it work unfortunately .
Your help is very much appreciated.

 

[jduzz]

Good morning Peter,

A question regarding your last post: I did some testing, and after I changed range "BO" to "BJ" (see the red code) it now copies the cell, but only the color and not the (link address) contents of the cell? Even when I just put some text in there, this is not copied.

Any ideas?

Thanks in advance.

 

[VoG]

This is fixed (not tested with a link)

Sub test()
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
Sheets("Sheet2").UsedRange.ClearContents
With Sheets("Sheet1")
    LR = .Range("F" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("F" & i)
            If .Value = "x" Then
                j = j + 1
                .Offset(, -5).Resize(, 13).Copy
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteValues
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteFormats
                Sheets("Sheet1").Range("BO" & i).Copy Destination:=Sheets("Sheet2").Range("N" & j)
            End If
        End With
    Next i
    j = j + 1
    For i = 1 To LR
        With .Range("F" & i)
            If .Value = "y" Then
                j = j + 1
                .Offset(, -5).Resize(, 13).Copy
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteValues
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteFormats
                Sheets("Sheet1").Range("BO" & i).Copy Destination:=Sheets("Sheet2").Range("N" & j)
            End If
        End With
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[jduzz]

Works like a charm!

By the way, I noticed that with copying the rows from sheet1 to sheet2, you also copy all the conditional formatting rules. I have been able to resolve that (all by myself : ) with the Clearcontents. statement. Now if I press the button, the first thing it does is get rid of all the old rules.

Last question: If I want to define in VBA to display a certain text, say at the beginning of the copied rows with 'x', what is the best command to do this?


Thanks,


JD


Simple last question: how do define in VBA how to display a certain text?

 

[VoG]

Last question: If I want to define in VBA to display a certain text, say at the beginning of the copied rows with 'x', what is the best command to do this?

Sorry, I don't understand.

 

[jduzz]

Let me correct myself about getting rid of those rules: I did this with the Formatconditions.delete statement.

 

[jduzz]

Okay, before I start printing the block of entries with an 'x' in sheet2, I would like a certain header above this block (in sheet2): "Here follow all rows with value x".

Just the same I would like a similar header above the block of rows with value y.

 

[VoG]

Try

Sub test()
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
Sheets("Sheet2").UsedRange.ClearContents
With Sheets("Sheet1")
    j = 1
    Sheets("Sheet2").Range("A" & j).Value = "Here are the x values"
    LR = .Range("F" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("F" & i)
            If .Value = "x" Then
                j = j + 1
                .Offset(, -5).Resize(, 13).Copy
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteValues
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteFormats
                Sheets("Sheet1").Range("BO" & i).Copy Destination:=Sheets("Sheet2").Range("N" & j)
            End If
        End With
    Next i
    j = j + 2
    Sheets("Sheet2").Range("A" & j).Value = "Here are the y values"
    For i = 1 To LR
        With .Range("F" & i)
            If .Value = "y" Then
                j = j + 1
                .Offset(, -5).Resize(, 13).Copy
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteValues
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteFormats
                Sheets("Sheet1").Range("BO" & i).Copy Destination:=Sheets("Sheet2").Range("N" & j)
            End If
        End With
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[jduzz]

This is getting great!

Would there be any way to change the background color of the cells (from the header to the last row) for each of the blocks x and y?

 

[VoG]

Try

Sub test()
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
Sheets("Sheet2").UsedRange.ClearContents
With Sheets("Sheet1")
    j = 1
    Sheets("Sheet2").Range("A" & j).Value = "Here are the x values"
    Sheets("Sheet2").Range("A" & j).Resize(, 14).Interior.ColorIndex = 20
    LR = .Range("F" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        With .Range("F" & i)
            If .Value = "x" Then
                j = j + 1
                .Offset(, -5).Resize(, 13).Copy
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteValues
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteFormats
                Sheets("Sheet1").Range("BO" & i).Copy Destination:=Sheets("Sheet2").Range("N" & j)
                Sheets("Sheet2").Range("A" & j).Resize(, 14).Interior.ColorIndex = 20
            End If
        End With
    Next i
    j = j + 2
    Sheets("Sheet2").Range("A" & j).Value = "Here are the y values"
    Sheets("Sheet2").Range("A" & j).Resize(, 14).Interior.ColorIndex = 24
    For i = 1 To LR
        With .Range("F" & i)
            If .Value = "y" Then
                j = j + 1
                .Offset(, -5).Resize(, 13).Copy
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteValues
                Sheets("Sheet2").Range("A" & j).PasteSpecial Paste:=xlPasteFormats
                Sheets("Sheet1").Range("BO" & i).Copy Destination:=Sheets("Sheet2").Range("N" & j)
                Sheets("Sheet2").Range("A" & j).Resize(, 14).Interior.ColorIndex = 24
            End If
        End With
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[jduzz]

This works really well.

Thanks again, you have saved me one major head ache!

Greetings,

JD