Copy cell above if it has no colour fill. Macro.

[Kirnon]

Hi,

So I have a small problem. I have a bunch of data which covers over 13000 rows and 64 columns. This extract lists changes in information but it only highlights the changes anything that hasn't changed is left blank. The information is always listed as 1 line with all old information followed by the line below with no information except the new information. New information can be that the change is to blank. new information is highlighted in Yellow.

Therefore using F5 - Special - Blanks doesn't work.
e
I need a quick vb code which simply fills in info from the line above IF that cell does not have any colour in it. (R:-1C)

I hope that I have been clear. Thanks in advance.

Kirnon.

 

[Kirnon]

Thank you Fluff,

Can you make a change? As the above is not working correctly.

In the formula If Cl.Interior.ColorIndex < 0 And [Don't know how to Code this] Range A and the row the macro is on = "" and Cl.Offset(1, 0).Interior.ColorIndex < 0 Then
Cl.Offset(1, 0) = Cl

ie. if A2 = "" then it should check the colours to determine if it should copy the above row, if not then it should just move on.

@ Arithos - Loop would be fine as I can leave things to run while working elsewhere.

 

[Arithos]

Thank you Fluff,

Can you make a change? As the above is not working correctly.

In the formula If Cl.Interior.ColorIndex < 0 And [Don't know how to Code this] Range A and the row the macro is on = "" and Cl.Offset(1, 0).Interior.ColorIndex < 0 Then
Cl.Offset(1, 0) = Cl

ie. if A2 = "" then it should check the colours to determine if it should copy the above row, if not then it should just move on.

@ Arithos - Loop would be fine as I can leave things to run while working elsewhere.

Good stuff, I'll make it when I have time

 

[Fluff]

Thank you Fluff,

Can you make a change? As the above is not working correctly.

In the formula If Cl.Interior.ColorIndex < 0 And [Don't know how to Code this] Range A and the row the macro is on = "" and Cl.Offset(1, 0).Interior.ColorIndex < 0 Then
Cl.Offset(1, 0) = Cl

ie. if A2 = "" then it should check the colours to determine if it should copy the above row, if not then it should just move on.

Does this do the trick?

Sub Kirnon()

    Dim LstRw As Long
    Dim WrkRng As Range
    Dim Cl As Range


    LstRw = Sheets("Changes").Range("A" & Rows.Count).End(xlUp).Row

    Set WrkRng = Sheets("Changes").Range("A2:AF" & LstRw)

    For Each Cl In WrkRng
        If Range("A" & LstRw) = "" And Cl.Interior.ColorIndex < 0 And Cl.Offset(-1,0).Interior.ColorIndex > 0 Then
            Cl = Cl.Offset(-1, 0)
        End If
    Next Cl
End Sub

 

[Kirnon]

That didn't work. Lol - seems to be more intricate than I had first thought it would be.

I am not sure why you are autofiltering.

the function:

Function GetFillColor(Rng As Range) As Long    GetFillColor = Rng.Interior.ColorIndex
End Function

along with the following formula does the trick in a new sheet:
=IF(Changes!$A2<>"",Changes!B2,IF(GetFillColor(Changes!B1)<0,IF(Changes!B1="","",Changes!B1),IF(Changes!B2="","",Changes!B2)))

 

[Fluff]

I am not sure why you are autofiltering.

I inadvertently left that in from something else I was looking at & have since edited the post.
This is what I was thinking of as it should be quicker

Sub Kirnon()

    Dim LstRw As Long
    Dim WrkRng As Range
    Dim Cl As Range


    LstRw = Sheets("Changes").Range("A" & Rows.Count).End(xlUp).Row

    Set WrkRng = Sheets("Changes").Range("A2:AF" & LstRw)

    Range("A1").AutoFilter Field:=1, Criteria1:=""

    For Each Cl In WrkRng.SpecialCells(xlCellTypeVisible)
        If Cl.Interior.ColorIndex < 0 And Cl.Offset(-1, 0).Interior.ColorIndex > 0 Then
            Cl = Cl.Offset(-1, 0)
        End If
        MsgBox Cl.Address
    Next Cl

    Range("A1").AutoFilter

End Sub

Assuming it works

 

[Arithos]

This one does what you want (in my sheet atleast)

Sub Kirnon2()


Dim LR As Long, LC As Long
Dim ch As Worksheet
Dim i As Integer, j As Integer
Set ch = Sheets("Changes")
    
    LR = ch.Range("A" & Rows.Count).End(xlUp).Row
    LC = ch.Range("AF1").Column
    
For i = 3 To LR  'here I assume your data starts in row 2, and is old data
    For j = 1 To LC
        If Not Cells(i, j).Interior.ColorIndex > 0 Then
            Cells(i, j).Value = Cells(i, j).Offset(-1, 0).Value
        End If
   
    Next j
i = i + 1
Next i


End Sub

Notice it only goes into everyother row, so it will not touch the old row.

Should not be THAAT slow either.

 

[Fluff]

Just realised that I left the message box in

        End If
         MsgBox Cl.Address
     Next Cl

Obviously this need to be removed

 

[Arithos]

This should be even faster.

Sub Kirnon2()
Dim LR As Long, LC As Long
Dim ch As Worksheet
Dim i As Integer, j As Integer
Set ch = Sheets("Changes")
    
    LR = ch.Range("A" & Rows.Count).End(xlUp).Row + 1
    LC = ch.Range("AF1").Column
    
Application.ScreenUpdating = False 'Hides calculations to make macro quicker
For i = 3 To LR Step 2  'here I assume your data starts in row 2,so start of "copy" is row 3
    For j = 1 To LC     ' Notice STEP 2, means it skips a row, when going through,
            If Not Cells(i, j).Interior.ColorIndex > 0 Then
                        Cells(i, j).Value = Cells(i, j).Offset(-1, 0).Value
            End If
    Next j
Next
Application.ScreenUpdating = True 'Makes it show calculations, when the macro is done
End Sub

@ Fluff, yeah you did =) and, your macro did not work on my end either. Can you try my macro aswell, and see if it works?

 

[Fluff]

@ Fluff, yeah you did =) and, your macro did not work on my end either. Can you try my macro aswell, and see if it works?

It doesn't work on my test data, but that may be because I have misunderstood what is req'd.
As I understand it
If cell in Column A is blank then for each cell in that row, if cell has no fill but cell directly above does, fill down. Else next

 

[Arithos]

It doesn't work on my test data, but that may be because I have misunderstood what is req'd.
As I understand it
If cell in Column A is blank then for each cell in that row, if cell has no fill but cell directly above does, fill down. Else next

I see, we have different understandings indeed.

we'll have to see what Kirnon says.