Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1244to1248
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Sepp

Sepp
Erich
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

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Sepp
16.01.2012 18:54:14
Josef

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 »

Anzeige
AW: Sepp
16.01.2012 20:00:44
Erich
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
Anzeige
AW: Sepp
16.01.2012 20:14:28
Josef

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 »

Anzeige
Korrektur Funktion
16.01.2012 21:32:02
Josef

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 »

Anzeige
AW: Korrektur Funktion
16.01.2012 21:58:59
Erich
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
AW: Korrektur Funktion
16.01.2012 22:27:25
Josef

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 »

Anzeige
AW: Korrektur Funktion
16.01.2012 22:50:14
Erich
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
Anzeige
AW: Korrektur Funktion
16.01.2012 23:11:31
Josef

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 »

Anzeige
AW: Korrektur Funktion
17.01.2012 08:34:39
Erich
Hallo Sepp,
Danke für Deine Geduld mit mir. Die Zellen waren nicht leer.
Gruß EM

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige