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]

Hi,

Aaaargh... I wish I new more about what I was doing. Anyway.

Fluff is right the Far Left Column (Column A) has the key and only if the cell in column A is blank should it attempt to fill the information, skipping lines doesn't work because occasionally it will list a line of someone that is no longer active - Column A will be filled in this instance.

 

[Fluff]

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

    Next Cl

    Range("A1").AutoFilter

End Sub

I take it that this didn't do what you need?
In which case can you give me some idea, of what needs changing?

 

[Arithos]

I think its hard to grasp what you rly want here =P

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
    If Cells(i, 1).Value = "" Then GoTo Nextit1
    For j = 2 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
Nextit1:
Next
Application.ScreenUpdating = True 'Makes it show calculations, when the macro is done
End Sub

This code assumes data starts in row 2, and row 3 is the row that will be filled with info from row 2, only and only if, cell A is "blank", but not alway "empty", may contain formula giving "". And so on.
There will ALWAYS be pairs, and the even numbered rows will have the old infor, and Odd numbered rows will have some new information...

Is this correct then?

 

[Arithos]

Basicly we need to know the "rule" of how you want it sorted. Somethine simple, if there are exceptions, these needs to be informed.

So far I got.

Start of data, row 2
pair of lines. always #1:Old #2: New
for each pair.
If, Column A cells are empty(only for #2 in row pairs) Then,
Copy whats in #1 in row pair, into #2 row in pair. As long as there is no color.
And loop.

This is what my macro does anyway, and expects no exceptions.

 

[Kirnon]

Here is an example: VBA should check if Column A cell is blank and if the cell it is to change is coloured. If both are true then copy the info from above.

	A	B	C	D	E
1		Key	Data2 / DataB	Data3 / DataC	Description / Desc
2	Changed	Alpha	$C$2	$D$2	zzz
3				xxx
4	Deleted	Beta	$C$3	$D$3	xxx
5	Deleted	Delta	$C$5	$D$5	vvv
6	Deleted	Epsiln	$C$6	$D$6	bbb
7	Changed	Zeta	$C$7	$D$7	nnn
8			bbb
9	Sheet1 only	Iota	$C$3	$D$3	bbb
10	Sheet1 only	Kappa	$C$5	$D$5	ddd
11	Sheet1 only	Lambda	$C$6	$D$6	eee

<tbody>
</tbody>

Sheet​

 

[Fluff]

Ok lets try this

Sub Kirnon()

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

Application.ScreenUpdating = False
    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" & Cl.Row) = "" And Cl.Interior.ColorIndex > 0 Then
            Cl = Cl.Offset(-1, 0)
        End If
    Next Cl

Application.ScreenUpdating = True
End Sub

 

[Arithos]

Here is an example: VBA should check if Column A cell is blank and if the cell it is to change is coloured. If both are true then copy the info from above.

	A	B	C	D	E
1		Key	Data2 / DataB	Data3 / DataC	Description / Desc
2	Changed	Alpha	$C$2	$D$2	zzz
3				xxx
4	Deleted	Beta	$C$3	$D$3	xxx
5	Deleted	Delta	$C$5	$D$5	vvv
6	Deleted	Epsiln	$C$6	$D$6	bbb
7	Changed	Zeta	$C$7	$D$7	nnn
8			bbb
9	Sheet1 only	Iota	$C$3	$D$3	bbb
10	Sheet1 only	Kappa	$C$5	$D$5	ddd
11	Sheet1 only	Lambda	$C$6	$D$6	eee

<tbody>
</tbody>

Sheet​

Ok, just change step 2, to step 1 then. And my macro should do it.

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 
For i = 2 To LR Step 1  
    If Cells(i, 1).Value <> "" Then GoTo Nextit1
    For j = 2 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
Nextit1:
Next
Application.ScreenUpdating = True
End Sub

Make sure there is no color in those cells then, And it seems like it should be filled when the cells in A1 are blank, Imisunderstood that one.

Atleast it does for the sample you provided.

 

[Kirnon]

Hi,

Well that's GREAT!! If slow, but honestly I expected it to be slow.

@Fluff: Yours doesn't seem to work correctly, it is changing everything in the colours leaving the cells outside of the colours blank. When I changed toe Interior.Cell > 0 to Interior.Cell < 0 it did the right thing but only in column A.

@Arithos: That works exactly as needed. Now if only there was a way to speed things up. Thank you both so much for your help.

 

[Arithos]

Hi,

Well that's GREAT!! If slow, but honestly I expected it to be slow.

@Fluff: Yours doesn't seem to work correctly, it is changing everything in the colours leaving the cells outside of the colours blank. When I changed toe Interior.Cell > 0 to Interior.Cell < 0 it did the right thing but only in column A.

@Arithos: That works exactly as needed. Now if only there was a way to speed things up. Thank you both so much for your help.

Yeah, expected mine to go slow. You could possibly use your first approach with using Ranges instead of going through every cell, but I dont have sufficient knowledge on this topic to do it. And dont know if there is another way.

Glad it finally works though, just took some time to realize what you actully needed =P

 

[Fluff]

Think I've finally realized what's needed. Not sure if will be any quicker than Arithos

Sub Kirnon()

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

Application.ScreenUpdating = False
    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 Then
            Cl = Cl.Offset(-1, 0)
        End If
    Next Cl
    Range("A1").AutoFilter

Application.ScreenUpdating = True
End Sub