Option Explicit
Sub ChkIt()
'
Dim rngCol As Excel.Range, rngTxt As Excel.Range, rngArea As Excel.Range
Dim rngNmb As Excel.Range, rngChk As Excel.Range
'
On Error GoTo ChkIt_Error
'
Set rngCol = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))
If rngCol.Cells.Count > 1 Then
If IsNumeric(rngCol.Cells(1)) Then
Set rngTxt = rngCol.SpecialCells(xlCellTypeConstants, 2)
For Each rngArea In rngTxt.Areas
Set rngNmb = rngArea.Cells(1).Offset(-1)
Set rngChk = rngNmb.Offset(, -1)
Set rngChk = rngChk.Resize(rngArea.Rows.Count + 1, 1)
rngChk = rngNmb
Next rngArea
End If
End If
'
On Error GoTo 0
'
ChkIt_Error:
Select Case Err.Number
Case Is = 0
Set rngChk = rngCol.Offset(, -1)
For Each rngNmb In rngChk
If Len(rngNmb) = 0 And IsNumeric(rngNmb.Offset(, 1)) Then _
rngNmb = rngNmb.Offset(, 1)
Next rngNmb
Case Is = 1004
Call MsgBox("keine Texte in Spalte", vbCritical, "Fehler")
Case Else
Call MsgBox("unbekannter Spaltenaufbau", vbCritical, "Fehler")
End Select
End Sub
|