Thread: Find first non-empty cell ranght from column A

Hi There,

Could anyone help me with the following?
If a cell in Column A form my Usedrange (supposing that Usedrange
starts in Column A) is empty I would like to copy the first non-blank
cell from that row into column A.

E.g.
A B C
1 Y Y Y
2 - - Z
3 - K -

Should become:
YYY
Z-Z
KK-

Hope this makes sense,
Sige

Hi Sige,

Try:

'=============>>
Public Sub Tester()
Dim rng As Range
Dim rng2 As Range
Dim rcell As Range

On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Columns("A"))
Set rng2 = rng.SpecialCells(xlBlanks)
On Error GoTo 0

If Not rng2 Is Nothing Then
For Each rcell In rng2.Cells
With rcell
.Resize(1, 2) = .End(xlToRight).Value
End With
Next rcell
End If

End Sub
'<<=============


---
Regards,
Norman



"Sige" <SIGE_GOEVAERTS@HOTMAIL.COM> wrote in message
news:1138977010.137265.314230@g47g2000cwa.googlegroups.com...
> Hi There,
>
> Could anyone help me with the following?
> If a cell in Column A form my Usedrange (supposing that Usedrange
> starts in Column A) is empty I would like to copy the first non-blank
> cell from that row into column A.
>
> E.g.
> A B C
> 1 Y Y Y
> 2 - - Z
> 3 - K -
>
> Should become:
> YYY
> Z-Z
> KK-
>
> Hope this makes sense,
> Sige
>

Hi Sige,

Looking again at your example data, change:

> .Resize(1, 2) = .End(xlToRight).Value

to:

.Value = .End(xlToRight).Value

---
Regards,
Norman

Hi Norman,

Thanks again.
It does exactly what it should!
No enhancements needed ... or if so, the inheritance of the
Font-formatting?

Brgds Sige


Norman Jones wrote:
> Hi Sige,
>
> Looking again at your example data, change:
>
> > .Resize(1, 2) = .End(xlToRight).Value
>
> to:
>
> .Value = .End(xlToRight).Value
>
> ---
> Regards,
> Norman

Hi Sige,

> No enhancements needed ... or if so, the inheritance of the
> Font-formatting?

Try:
'=============>>
Public Sub Tester2()
Dim rng As Range
Dim rng2 As Range
Dim rCell As Range

On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Columns("A"))
Set rng2 = rng.SpecialCells(xlBlanks)
On Error GoTo 0

If Not rng2 Is Nothing Then
For Each rCell In rng2.Cells
With rCell
.End(xlToRight).Copy Destination:=.Item(1)
End With
Next rCell
End If

End Sub
'<<=============


---
Regards,
Norman



"Sige" <SIGE_GOEVAERTS@HOTMAIL.COM> wrote in message
news:1138980918.129115.315340@g43g2000cwa.googlegroups.com...
> Hi Norman,
>
> Thanks again.
> It does exactly what it should!
> No enhancements needed ... or if so, the inheritance of the
> Font-formatting?
>
> Brgds Sige
>
>
> Norman Jones wrote:
>> Hi Sige,
>>
>> Looking again at your example data, change:
>>
>> > .Resize(1, 2) = .End(xlToRight).Value
>>
>> to:
>>
>> .Value = .End(xlToRight).Value
>>
>> ---
>> Regards,
>> Norman
>

Hi Norman,

It is not only the Font formatting it inherits... but it is more than
fine!

Thank you very much,
Un buono fine settimana!
Ciao Sige

PS: Tu hai ricevuto il titolo di mvp questo anno?

Hi Sige,

> It is not only the Font formatting it inherits... but it is more than
> fine!


Try:
'=============>>
Public Sub Teste3()
Dim rng As Range
Dim rng2 As Range
Dim rCell As Range

On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Columns("A"))
Set rng2 = rng.SpecialCells(xlBlanks)
On Error GoTo 0

If Not rng2 Is Nothing Then
For Each rCell In rng2.Cells
With rCell
.Value = .End(xlToRight).Value
.Font.Name = .End(xlToRight).Font.Name
.Font.FontStyle = .End(xlToRight).Font.FontStyle
.Font.Size = .End(xlToRight).Font.Size
.Font.Underline = .End(xlToRight).Font.Underline
.Font.ColorIndex = .End(xlToRight).Font.ColorIndex
End With
Next rCell
End If

End Sub
'<<=============

---
Regards,
Norman

Hi Norman,

Thanks, thanks, thanks!
Brgds Sige


Norman Jones wrote:
> Hi Sige,
>
> > It is not only the Font formatting it inherits... but it is more than
> > fine!
>
>
> Try:
> '=============>>
> Public Sub Teste3()
> Dim rng As Range
> Dim rng2 As Range
> Dim rCell As Range
>
> On Error Resume Next
> Set rng = Intersect(ActiveSheet.UsedRange, Columns("A"))
> Set rng2 = rng.SpecialCells(xlBlanks)
> On Error GoTo 0
>
> If Not rng2 Is Nothing Then
> For Each rCell In rng2.Cells
> With rCell
> .Value = .End(xlToRight).Value
> .Font.Name = .End(xlToRight).Font.Name
> .Font.FontStyle = .End(xlToRight).Font.FontStyle
> .Font.Size = .End(xlToRight).Font.Size
> .Font.Underline = .End(xlToRight).Font.Underline
> .Font.ColorIndex = .End(xlToRight).Font.ColorIndex
> End With
> Next rCell
> End If
>
> End Sub
> '<<=============
>
> ---
> Regards,
> Norman

Hi Norman,

I am trying to let you sub work for all the ws in my wbk.
I ended up with this sub:

To me it seems logic ... and it works!
Though it does not pick up the formatting in my practical example?!
(In an example new virgin workbook it does, but not in the wbk on which
I would like to apply it...?)

Bizar behaviour ... You have -again- any idea?

Best Regards, Sige

'=============>>
Public Sub Tester3()
Dim rng As Range
Dim rng2 As Range
Dim rCell As Range
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next
Set rng = Intersect(ws.UsedRange, ws.Columns("A"))
Set rng2 = rng.SpecialCells(xlBlanks)
On Error GoTo 0

If Not rng2 Is Nothing Then
For Each rCell In rng2.Cells
With rCell
.Value = .End(xlToRight).Value

.Font.Name = .End(xlToRight).Font.Name
.Font.FontStyle = .End(xlToRight).Font.FontStyle
.Font.Bold = .End(xlToRight).Font.Bold
.Font.Size = .End(xlToRight).Font.Size
.Font.Underline = .End(xlToRight).Font.Underline
.Font.ColorIndex = .End(xlToRight).Font.ColorIndex

End With
Next rCell
End If
Next ws
End Sub

Hi Sige,

> I am trying to let you sub work for all the ws in my wbk.
> I ended up with this sub:
>
> To me it seems logic ... and it works!
> Though it does not pick up the formatting in my practical example?!
> (In an example new virgin workbook it does, but not in the wbk on which
> I would like to apply it...?)
>
> Bizar behaviour ... You have -again- any idea?

Send me a copy of a problematic workbook. Replace any private data.


---
Regards,
Norman