Microsoft Excel

Herbers Excel/VBA-Archiv

Sepp | Herbers Excel-Forum


Betrifft: Sepp von: Erich Müller
Geschrieben am: 16.01.2012 16:48:15

Hallo Sepp,

Du hast mir letzte Woche ein Makro geschickt, das ich nicht ganz verstehe.
Es sind die Zellen K6:N300 gefüllt. Dazwischen gibt es auch Leerzellen.
Wenn ich nun die letzte Leerzelle mit einem Wert versehen habe, sollte der Cursor auf K301 stehen.
Tut er aber nicht. Er steht auf K6 !?!

Private Sub Worksheet_Activate()
  Dim rng As Range
  On Error Resume Next
  Set rng = Range("K6:K309").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
  On Error GoTo 0
  If Not rng Is Nothing Then Application.Goto rng
  Set rng = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, lngC As Long
  If Not Intersect(Target, Range("K6:N309")) Is Nothing Then
    On Error Resume Next
    lngC = Target(1, 1).Column - 10
    If lngC > 3 Then lngC = 0
    Set rng = Range("K6:K309").Offset(0, lngC).SpecialCells(xlCellTypeBlanks).Cells(1, 1)
    On Error GoTo 0
    If Not rng Is Nothing Then
      Application.Goto rng
    Else
      Application.Goto Range("K6:K309").Offset(0, lngC).Cells(1, 1)
    End If
  End If
  Set rng = Nothing
End Sub
Über Deine Antwort würde ich mich freuen.

Gruß EM

  

Betrifft: AW: Sepp von: Josef Ehrensberger
Geschrieben am: 16.01.2012 18:54:14


Hallo Erich,

SpecialCells wird seine Ruf wieder mal gerecht, man sollte sich nicht unbedingt immer darauf verlassen ;-((

Hier der Ersatzcode.

' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Activate()
  Dim rng As Range
  On Error Resume Next
  Set rng = Range("K6:K309").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
  On Error GoTo 0
  If Not rng Is Nothing Then Application.Goto rng
  Set rng = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, lngC As Long
  If Not Intersect(Target, Range("K6:N309")) Is Nothing Then
    On Error Resume Next
    lngC = Target(1, 1).Column - 10
    If lngC > 3 Then lngC = 0
    Set rng = EmptyCell(Range("K6:K309").Offset(0, lngC))
    On Error GoTo 0
    If Not rng Is Nothing Then
      Application.Goto rng
    Else
      Application.Goto Range("K6:K309").Offset(0, lngC).Cells(1, 1)
    End If
  End If
  Set rng = Nothing
End Sub


Private Function EmptyCell(Target As Range) As Range
  Dim vntRet As Variant
  With Target
    vntRet = Evaluate("MIN(IF(" & .Address & "="""",ROW(" & .Address & _
      ")+COLUMN(" & .Address & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    Set EmptyCell = .Cells(Application.Max(1, Fix(vntRet) - .Rows(1).Row + 1), _
      Application.Max(1, Fix((vntRet - Int(vntRet)) * 10 ^ 6) - .Columns(1).Column + 1))
  End With
End Function





« Gruß Sepp »



  

Betrifft: AW: Sepp von: Erich Müller
Geschrieben am: 16.01.2012 20:00:44

Hallo Sepp,

Danke für Deinen Ersatzcode.
Nun habe ich mir erlaubt, in Deinem u.a. Makro das Ziel von 309 auf 30 zu ändern. Das Makro reagiert aber nur bis Zeile 28 !?!

Private Sub Worksheet_Activate()
  Dim rng As Range
  On Error Resume Next
  Set rng = Range("K6:K309").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
  On Error GoTo 0
  If Not rng Is Nothing Then Application.Goto rng
  Set rng = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range
  If Not Intersect(Target, Range("K6:L309")) Is Nothing Then
    On Error Resume Next
    If Target(1, 1).Column = 11 Then
      Set rng = Range("L6:L309").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
    Else
      Set rng = Range("K6:K309").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
    End If
    On Error GoTo 0
    If Not rng Is Nothing Then Application.Goto rng
  End If
  Set rng = Nothing
End Sub
Über Deine Antwort würde ich mich freuen.

Gruß EM


  

Betrifft: AW: Sepp von: Josef Ehrensberger
Geschrieben am: 16.01.2012 20:14:28


Hallo Erich,

kann ich nicht nachvollziehen, anbei ein angepasster Code mit der Möglichkeit, den Bereich einfacher anzupassen.

' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cstrRange As String = "K6:N30" 'Gültigkeitsbereich

Private Sub Worksheet_Activate()
  Dim rng As Range
  On Error Resume Next
  Set rng = EmptyCell(Range(cstrRange).Columns(1))
  On Error GoTo 0
  If Not rng Is Nothing Then Application.Goto rng
  Set rng = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, lngC As Long
  If Not Intersect(Target, Range(cstrRange)) Is Nothing Then
    On Error Resume Next
    lngC = Target(1, 1).Column - 10
    If lngC > 3 Then lngC = 0
    Set rng = EmptyCell(Range(cstrRange).Columns(1).Offset(0, lngC))
    On Error GoTo 0
    If Not rng Is Nothing Then
      Application.Goto rng
    Else
      Application.Goto Range(cstrRange).Columns(1).Offset(0, lngC).Cells(1, 1)
    End If
  End If
  Set rng = Nothing
End Sub


Private Function EmptyCell(Target As Range) As Range
  Dim vntRet As Variant
  With Target
    vntRet = Evaluate("MIN(IF(" & .Address & "="""",ROW(" & .Address & _
      ")+COLUMN(" & .Address & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    Set EmptyCell = .Cells(Application.Max(1, Fix(vntRet) - .Rows(1).Row + 1), _
      Application.Max(1, Fix((vntRet - Int(vntRet)) * 10 ^ 6) - .Columns(1).Column + 1))
  End With
End Function






« Gruß Sepp »



  

Betrifft: Korrektur Funktion von: Josef Ehrensberger
Geschrieben am: 16.01.2012 21:32:02


Hallo Erich,

die Funktion hatte noch einen Fehler.

Private Function EmptyCell(Target As Range) As Range
  Dim vntRet As Variant
  With Target
    vntRet = Evaluate("MIN(IF(" & .Address & "="""",ROW(" & .Address & _
      ")+COLUMN(" & .Address & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    Set EmptyCell = .Cells(Clng(Split(vntRet, ",")(0)) - .Rows(1).Row + 1, _
      Clng(Split(vntRet, ",")(1)) - .Columns(1).Column + 1)
  End With
End Function




« Gruß Sepp »



  

Betrifft: AW: Korrektur Funktion von: Erich Müller
Geschrieben am: 16.01.2012 21:58:59

Hallo Sepp,

es tut mir leid, aber.......
Nach den Eingaben in den Spalten K:L im Bereich Zeilen 6:30 springt der Cursor auf M6 !?!

Gruß Erich


  

Betrifft: AW: Korrektur Funktion von: Josef Ehrensberger
Geschrieben am: 16.01.2012 22:27:25


Hallo Erich,

ja wo soll er denn auch hin? Der Bereich ist voll, da gibt's keine leeren Zellen mehr.

Was bei vollständig gefülltem Bereich geschehen soll, hast du nie erwähnt.




« Gruß Sepp »



  

Betrifft: AW: Korrektur Funktion von: Erich Müller
Geschrieben am: 16.01.2012 22:50:14

Hallo Sepp,

wir reden von verschiedenen Makros. Es geht nicht von K6:N30, sondern von K6:L30. Also nur zwei Spalten. Da hört die Eingabe mit Zeile 28 auf !?!

Private Sub Worksheet_Activate()
      Dim rng As Range
      On Error Resume Next
      Set rng = Range("K6:K30").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
      On Error GoTo 0
      If Not rng Is Nothing Then Application.Goto rng
      Set rng = Nothing
    End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
      Dim rng As Range
      If Not Intersect(Target, Range("K6:L30")) Is Nothing Then
        On Error Resume Next
        If Target(1, 1).Column = 11 Then
          Set rng = Range("L6:L30").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
        Else
          Set rng = Range("K6:K30").SpecialCells(xlCellTypeBlanks).Cells(1, 1)
        End If
        On Error GoTo 0
        If Not rng Is Nothing Then Application.Goto rng
      End If
      Set rng = Nothing
    End Sub

Über Deine Antwort würde ich mich freuen.

Gruß EM


  

Betrifft: AW: Korrektur Funktion von: Josef Ehrensberger
Geschrieben am: 16.01.2012 23:11:31


Hallo Erich,

wir drehen uns im Kreis.

Ich hatte geschrieben, das SoecialCells in diesem Fall zu unsicher ist und dir eine Alternative geboten.

Du postest aber andauernd den alten Code und sagst "geht nicht", wenn es auch mit diesem Code nicht geht, dann sind deine Zellen einfach nicht leer!

' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cstrRange As String = "K6:L30" 'Gültigkeitsbereich

Private Sub Worksheet_Activate()
  Dim rng As Range
  On Error Resume Next
  Set rng = EmptyCell(Range(cstrRange).Columns(1))
  On Error GoTo 0
  If Not rng Is Nothing Then Application.Goto rng
  Set rng = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, lngC As Long
  If Not Intersect(Target, Range(cstrRange)) Is Nothing Then
    On Error Resume Next
    lngC = Target(1, 1).Column - Range(cstrRange).Columns(1).Column + 1
    If lngC > Range(cstrRange).Columns.Count - 1 Then lngC = 0
    Set rng = EmptyCell(Range(cstrRange).Columns(1).Offset(0, lngC))
    On Error GoTo 0
    If Not rng Is Nothing Then
      Application.Goto rng
    Else
      Application.Goto Range(cstrRange).Columns(1).Offset(0, lngC).Cells(1, 1)
    End If
  End If
  Set rng = Nothing
End Sub


Private Function EmptyCell(Target As Range) As Range
  Dim vntRet As Variant
  With Target
    vntRet = Evaluate("MIN(IF(" & .Address & "="""",ROW(" & .Address & _
      ")+COLUMN(" & .Address & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    Set EmptyCell = .Cells(Clng(Split(vntRet, ",")(0)) - .Rows(1).Row + 1, _
      Clng(Split(vntRet, ",")(1)) - .Columns(1).Column + 1)
  End With
End Function






« Gruß Sepp »



  

Betrifft: AW: Korrektur Funktion von: Erich Müller
Geschrieben am: 17.01.2012 08:34:39

Hallo Sepp,

Danke für Deine Geduld mit mir. Die Zellen waren nicht leer.

Gruß EM