Find first non-empty cell ranght from column A

[Sige]

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

 

[Norman Jones]

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
'<<=============

 

[Norman Jones]

Hi Sige,

Looking again at your example data, change:

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

to:

.Value = .End(xlToRight).Value

 

[Sige]

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]

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

Hi Norman,

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

Brgds Sige

 

[Sige]

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?

 

[Norman Jones]

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
'<<=============

 

[Sige]

Hi Norman,

Thanks, thanks, thanks!
Brgds Sige

Hi Sige,



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
'<<=============

 

[Sige]

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

 

[Norman Jones]

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.