macro copy condition format colours

[ste33uka]

Hi could anyone change or add to the following macro
I would like it to also copy the cell colours which are created by condition format, but not copy the rules, just the colours

Sub Copy_to_book()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim i As Long
    Dim lastRow As Long

    For i = 1 To 101
        With Sheets(CStr(i))
            If LCase(.Range("vZ2").Value) = "yes" Then
                lastRow = Workbooks("Book1").Sheets("CARDS").Cells(Rows.Count, "A").End(xlUp).Row + 1

                Workbooks("Book1").Sheets("CARDS").Range("A" & lastRow & ":ET" & lastRow + 74).Value = .Range("A1:ET75").Value
            End If
        End With
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[6StringJazzer]

Give this a try. Cannot test without your file, but I tested on a simpler test file.

Sub Copy_to_book()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim i As Long
    Dim lastRow As Long
    Dim f As Long

    For i = 1 To 101
        With Sheets(CStr(i))
            If LCase(.Range("vZ2").Value) = "yes" Then
                lastRow = Workbooks("Book1").Sheets("CARDS").Cells(Rows.Count, "A").End(xlUp).Row + 1

                Workbooks("Book1").Sheets("CARDS").Range("A" & lastRow & ":ET" & lastRow + 74).Value = .Range("A1:ET75").Value
                For f = 1 To .Range("A1:ET75").Count
                   Workbooks("Book1").Sheets("CARDS").Range("A" & lastRow & ":ET" & lastRow + 74)(f).Interior.Color = .Range("A1:ET75")(f).DisplayFormat.Interior.Color
                Next f


            End If
        End With
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[ste33uka]

Give this a try. Cannot test without your file, but I tested on a simpler test file.

Sub Copy_to_book()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim i As Long
    Dim lastRow As Long
    Dim f As Long

    For i = 1 To 101
        With Sheets(CStr(i))
            If LCase(.Range("vZ2").Value) = "yes" Then
                lastRow = Workbooks("Book1").Sheets("CARDS").Cells(Rows.Count, "A").End(xlUp).Row + 1

                Workbooks("Book1").Sheets("CARDS").Range("A" & lastRow & ":ET" & lastRow + 74).Value = .Range("A1:ET75").Value
                For f = 1 To .Range("A1:ET75").Count
                   Workbooks("Book1").Sheets("CARDS").Range("A" & lastRow & ":ET" & lastRow + 74)(f).Interior.Color = .Range("A1:ET75")(f).DisplayFormat.Interior.Color
                Next f


            End If
        End With
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Thanks alot bud, works great

​

 

[RustamMika]

Hi ,
Try this:

Sub Copy_to_book()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim i As Long
    Dim lastRow As Long

    For i = 1 To 101
        With Sheets(CStr(i))
            If LCase(.Range("vZ2").Value) = "yes" Then
                lastRow = Workbooks("Book1").Sheets("CARDS").Cells(Rows.Count, "A").End(xlUp).Row + 1
                For m = lastRow To lastRow + 74
                 k = k + 1
                    For n = 1 To 150
                        Workbooks("Book1").Sheets("CARDS").Cells(m, n).Value = .Cells(k, n).Value
                        Workbooks("Book1").Sheets("CARDS").Cells(m, n).Interior.Color = .Cells(k, n).DisplayFormat.Interior.Color
                        
                     Next
                Next
            End If
        End With
    Next i
End Sub

 

[6StringJazzer]

Hi ,
Try this:

Did you test that? I tried the same thing and it just used the color value 0 to copy to all other cells, rather than copying from each corresponding cell. That's why I did the loop.

 

[ste33uka]

Did you test that? I tried the same thing and it just used the color value 0 to copy to all other cells, rather than copying from each corresponding cell. That's why I did the loop.

Yes tested it and works! Cheers