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

K

Kirnon

Board Regular
Joined
Apr 23, 2008
Messages
110
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.
 
Sort by date Sort by votes
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.
 
Upvote 0

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Code: 
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?
 
Upvote 0
I think its hard to grasp what you rly want here =P


Code: 
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?
 
Last edited:
Upvote 0
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.
 
Upvote 0
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.

ABCDE
KeyData2 / DataBData3 / DataCDescription / Desc
ChangedAlpha$C$2zzz
Deleted
Deleted
Deleted
ChangedZeta$D$7nnn
Sheet1 only
Sheet1 only
Sheet1 only

<tbody>
[TD="align: center"]1[/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="bgcolor: #FFFF00"]$D$2[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="bgcolor: #FFFF00"]xxx[/TD]

[TD="align: center"]4[/TD]

[TD="bgcolor: #C0C0C0"]Beta[/TD]
[TD="bgcolor: #C0C0C0"]$C$3[/TD]
[TD="bgcolor: #C0C0C0"]$D$3[/TD]
[TD="bgcolor: #C0C0C0"]xxx[/TD]

[TD="align: center"]5[/TD]

[TD="bgcolor: #C0C0C0"]Delta[/TD]
[TD="bgcolor: #C0C0C0"]$C$5[/TD]
[TD="bgcolor: #C0C0C0"]$D$5[/TD]
[TD="bgcolor: #C0C0C0"]vvv[/TD]

[TD="align: center"]6[/TD]

[TD="bgcolor: #C0C0C0"]Epsiln[/TD]
[TD="bgcolor: #C0C0C0"]$C$6[/TD]
[TD="bgcolor: #C0C0C0"]$D$6[/TD]
[TD="bgcolor: #C0C0C0"]bbb[/TD]

[TD="align: center"]7[/TD]

[TD="bgcolor: #FFFF00"]$C$7[/TD]

[TD="align: center"]8[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="bgcolor: #FFFF00"]bbb[/TD]
[TD="align: right"][/TD]

[TD="align: center"]9[/TD]

[TD="bgcolor: #00FF00"]Iota[/TD]
[TD="bgcolor: #00FF00"]$C$3[/TD]
[TD="bgcolor: #00FF00"]$D$3[/TD]
[TD="bgcolor: #00FF00"]bbb[/TD]

[TD="align: center"]10[/TD]

[TD="bgcolor: #00FF00"]Kappa[/TD]
[TD="bgcolor: #00FF00"]$C$5[/TD]
[TD="bgcolor: #00FF00"]$D$5[/TD]
[TD="bgcolor: #00FF00"]ddd[/TD]

[TD="align: center"]11[/TD]

[TD="bgcolor: #00FF00"]Lambda[/TD]
[TD="bgcolor: #00FF00"]$C$6[/TD]
[TD="bgcolor: #00FF00"]$D$6[/TD]
[TD="bgcolor: #00FF00"]eee[/TD]

</tbody>
Sheet​
 
Upvote 0
Ok lets try this
Code: 
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
 
Upvote 0
Kirnon said:
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.

ABCDE
KeyData2 / DataBData3 / DataCDescription / Desc
ChangedAlpha$C$2zzz
Deleted
Deleted
Deleted
ChangedZeta$D$7nnn
Sheet1 only
Sheet1 only
Sheet1 only

<tbody>
[TD="align: center"]1[/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="bgcolor: #FFFF00"]$D$2[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="bgcolor: #FFFF00"]xxx[/TD]

[TD="align: center"]4[/TD]

[TD="bgcolor: #C0C0C0"]Beta[/TD]
[TD="bgcolor: #C0C0C0"]$C$3[/TD]
[TD="bgcolor: #C0C0C0"]$D$3[/TD]
[TD="bgcolor: #C0C0C0"]xxx[/TD]

[TD="align: center"]5[/TD]

[TD="bgcolor: #C0C0C0"]Delta[/TD]
[TD="bgcolor: #C0C0C0"]$C$5[/TD]
[TD="bgcolor: #C0C0C0"]$D$5[/TD]
[TD="bgcolor: #C0C0C0"]vvv[/TD]

[TD="align: center"]6[/TD]

[TD="bgcolor: #C0C0C0"]Epsiln[/TD]
[TD="bgcolor: #C0C0C0"]$C$6[/TD]
[TD="bgcolor: #C0C0C0"]$D$6[/TD]
[TD="bgcolor: #C0C0C0"]bbb[/TD]

[TD="align: center"]7[/TD]

[TD="bgcolor: #FFFF00"]$C$7[/TD]

[TD="align: center"]8[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="bgcolor: #FFFF00"]bbb[/TD]
[TD="align: right"][/TD]

[TD="align: center"]9[/TD]

[TD="bgcolor: #00FF00"]Iota[/TD]
[TD="bgcolor: #00FF00"]$C$3[/TD]
[TD="bgcolor: #00FF00"]$D$3[/TD]
[TD="bgcolor: #00FF00"]bbb[/TD]

[TD="align: center"]10[/TD]

[TD="bgcolor: #00FF00"]Kappa[/TD]
[TD="bgcolor: #00FF00"]$C$5[/TD]
[TD="bgcolor: #00FF00"]$D$5[/TD]
[TD="bgcolor: #00FF00"]ddd[/TD]

[TD="align: center"]11[/TD]

[TD="bgcolor: #00FF00"]Lambda[/TD]
[TD="bgcolor: #00FF00"]$C$6[/TD]
[TD="bgcolor: #00FF00"]$D$6[/TD]
[TD="bgcolor: #00FF00"]eee[/TD]

</tbody>
Sheet​
Click to expand...

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


Code: 
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.
 
Last edited:
Upvote 0
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.
 
Upvote 0
Kirnon said:
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.
Click to expand...

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
 
Upvote 0
Think I've finally realized what's needed. Not sure if will be any quicker than Arithos
Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
VBA Search a range for a value, then copy and paste data only from source to defined cells.
Replies
0
Views
233
Davion615
D
L
  • Solved
copy cell and cell above onto different sheet, under the next available line.
Replies
5
Views
240
Alex Blakenburg
A
W
  • Question Question
Formatting raw data with extra rows automatically added in-between records
Replies
1
Views
134
Peter_SSs
Peter_SSs
W
  • Solved
vba/macro to Find a line on another sheet and replace information in just 1 cell in that line
Replies
5
Views
138
mumps
mumps
V
  • Question Question
Calculating coloured/uncoloured cells in a table
Replies
0
Views
102
vikosh
V

Forum statistics

Threads
1,225,481
Messages
6,185,239
Members
453,283
Latest member
Shortm88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top