Microsoft Excel

Herbers Excel/VBA-Archiv

VBA - 1 Codefehler habe ich noch | Herbers Excel-Forum


Betrifft: VBA - 1 Codefehler habe ich noch von: WalterK
Geschrieben am: 03.02.2012 19:08:29

Hallo,

Schon vor längerer Zeit habe ich aus dem Internet einen Code erhalten, der in einer gefilterten Tabelle bezugnehmend auf die Spalte A blockweise Hintergrundfarben setzt.

Den Code habe ich in der personl.xls gespeichert, damit er immer zur Verfügung steht. Bei jedem Klick auf die eigens erstellte Schaltfläche in der Symbolleiste wird wieder der nächste TextBlock markiert.

Der Code funktioniert soweit auch ganz gut, allerdings kommt es manchmal vor, dass der Code abbricht und dann wird die Zeile booGoErste = Intersect(rngAktuell, rngVisibleRange) Is Nothing

 markiert. Wenn ich den Debugger beende, kann ich normal weiterklicken und der Code markiert wie gewünscht.

Ich komme einfach nicht dahinter, wieso hier ein Fehler kommt.

Wenn ich den Code direkt in eine Mappe kopiere kommt nie ein Fehler. Er sollte aber in der personl.xls laufen.

Zum besseren Verständnis habe ich den Code in eine Beispielmappe kopiert. Vielleicht weiß jemand Rat.
https://www.herber.de/bbs/user/78727.xls

Bin gespannt, Danke und Servus, Walter

  

Betrifft: Pack den Code in ein Modul.. oT von: robert
Geschrieben am: 03.02.2012 19:22:50




  

Betrifft: Sorry, vergiss meine Antwort :-) owT von: robert
Geschrieben am: 03.02.2012 19:26:09




  

Betrifft: Eines habe ich noch vergessen zu ... von: WalterK
Geschrieben am: 03.02.2012 20:22:44

Hallo,

... erwähnen:

Der Fehler kommt, wenn er denn auftritt, immer nur zu Beginn einer Klickserie. Damit meine ich: wenn beim 1. Klick kein Fehler kommt, kommt in dieser Serie nie mehr ein Fehler.

Servus, Walter


  

Betrifft: Probier mal das... von: robert
Geschrieben am: 03.02.2012 20:58:13

Hi,

ändere diese Zeile im Code

Set rngAktuell = rngAktuell.Cells(1, 1)
auf

Set rngAktuell = rngAktuell.Cells(3, 1)

Gruß
robert


  

Betrifft: AW: Probier mal das... von: WalterK
Geschrieben am: 03.02.2012 21:07:10

Hallo Robert,

habe es probiert, der Code hat wieder abgebrochen und die gewohnte Codezeile markiert.

Servus, Walter


  

Betrifft: Hab mal getestet (keine Probleme) von: Matthias L
Geschrieben am: 04.02.2012 09:03:27

Hallo Walter

Ich habe mal, so wie Du es beschrieben hast den Code, (so wie er in Deiner Datei steht ) aus der Personl.xls gestartet.
Dabei trat das Problem nicht ein einziges Mal auf.
Vieleicht kannst Du mal eingrenzen wann genau der Fehler auftritt.
Um diesen Fehler zu reproduzieren wären ein paar mehr Infos von Vorteil.

z.B.


  • Welche Zelle war gerade die aktive Zelle (vor: Application.Goto)

  • Nach welchen Kriterien hast Du gerade den Filter gesetzt

  • Ist schon irgend ein Block gefärbt

  • Ist nur die eine Mappe (+ die Personl.xls) geöfnet

  • Welchen Inhalt haben die Variablen zu diesem Zeitpunkt



Übrigens gehören alle Dim-Anweisungen vor den Code - kein Muss, aber sollte so sein ;o)

Dim lngLetzte As Long, nCount As Long
Dim rngVisibleRange As Range
Static rngAktuell As Range
Dim booGoErste As Boolean
Dim LCol As Integer
Dim LoJ As Long 'auch diese hier
Dim i
Dim j
Dim k
Dim l
On Error Resume Next ' und das hilft zur Not auch als letztes Mittel

Gruß Matthias


  

Betrifft: AW: Hab mal getestet (keine Probleme) von: Hajo_Zi
Geschrieben am: 04.02.2012 09:07:02

Hallo Matthias,

vor dem Code nur falls Sie Modulweit benutzt werden. Im Makro hat den Vorteil die Variablen mit Dim sind zu Beginn leer.

GrußformelHomepage


  

Betrifft: AW: Hab mal getestet (keine Probleme) von: WalterK
Geschrieben am: 04.02.2012 09:37:42

Hallo Matthias,

hier einige Infos zur Erläuterung:
-- Wenn ich die Mappe öffne ist in allen Blättern die Zelle A1 aktiv.
-- Den Filter habe ich herausgenommen, am Fehler hat sich nichts geändert.
-- In den Blättern ist noch nichts gefärbt.
-- Es ist immer nur die eine Mappe geöffnet
-- Zum Inhalt der Variablen kann ich nichts sagen, weil ich keine Ahnung habe, was Du meinst.

Der Fehler tritt nie auf wenn ich eine Mappe öffne, sondern immer dann, wenn ich danach im nächsten Blatt weitermachen will und wieder den Code benutze.

Ich habe nochmals eine Mappe mit 5 Blättern zum Testen angelegt.
https://www.herber.de/bbs/user/78735.xls

Wo müsste ich denn On Error Resume Next genau platzieren?

Besten Dank für Deine Hilfe, Servus Walter


  

Betrifft: On Error Resume Next ... von: Matthias L
Geschrieben am: 04.02.2012 10:24:40

Hallo

On Error Resume Next unter die letzte Dim-Anweisung

Option Explicit
Sub Walter()
Dim lngLetzte As Long, nCount As Long
Dim rngVisibleRange As Range
Static rngAktuell As Range
Dim booGoErste As Boolean
Dim LCol As Integer
Dim LoJ As Long
Dim i
Dim j
Dim k
Dim l
On Error Resume Next

      LCol = Cells(2, Columns.Count).End(xlToLeft).Column
      Set rngVisibleRange = Range("A3", Cells(Rows.Count, 1)).SpecialCells(xlCellTypeVisible)
      booGoErste = rngAktuell Is Nothing
      
      If Not booGoErste Then
         booGoErste = Intersect(rngAktuell, rngVisibleRange) Is Nothing
      End If
      
      If booGoErste Then
         Set rngAktuell = rngVisibleRange
         Set rngAktuell = rngAktuell.Cells(1, 1)
         Application.GoTo rngAktuell, True
         Exit Sub
      End If
      
      lngLetzte = Cells(Rows.Count, 1).End(xlUp).Row
      nCount = rngAktuell.Row + 1
      
      Do While rngAktuell.Row <= lngLetzte
         If Not Intersect(Cells(nCount, 1), rngVisibleRange) Is Nothing Then
            If rngAktuell = Cells(nCount, 1) Then
               nCount = nCount + 1
            Else
               Set rngAktuell = Cells(nCount, 1)
               Application.GoTo rngAktuell, True
               Exit Do
            End If
         Else
             nCount = nCount + 1
         End If
      Loop
      
      If nCount > lngLetzte Then
         Set rngAktuell = Range("A3", Cells(Rows.Count, 1)).SpecialCells(xlCellTypeVisible)
         Set rngAktuell = rngAktuell.Cells(1, 1)
         ' rngAktuell ist die erste Zelle des blocks
         Application.GoTo rngAktuell, True
      End If
      
      i = Application.Match("BEZEICHNUNG", Rows(2), 0)
      j = Application.Match("JÄNNER", Rows(2), 0)
      k = Application.Match("DEZEMBER", Rows(2), 0)
      l = Application.Match("GESAMT", Rows(2), 0)
      
      Range(Cells(3, 1), Cells(65536, i - 1)).Interior.ColorIndex = xlNone
      Range(Cells(3, i + 1), Cells(65536, j - 1)).Interior.ColorIndex = xlNone
      Range(Cells(3, k + 1), Cells(65536, LCol)).Interior.ColorIndex = xlNone
      
      
      For LoJ = rngAktuell.Row To lngLetzte
          If Cells(LoJ, 1) <> rngAktuell.Value Then Exit For
      Next LoJ
      
      Range(Cells(rngAktuell.Row, 1), Cells(LoJ - 1, i - 1)).Interior.Color = 16764108
      Range(Cells(rngAktuell.Row, i + 1), Cells(LoJ - 1, j - 1)).Interior.Color = 16764108
      Range(Cells(rngAktuell.Row, k + 1), Cells(LoJ - 1, LCol)).Interior.Color = 16764108

  End Sub

Gruß Matthias


  

Betrifft: AW: On Error Resume Next ... von: WalterK
Geschrieben am: 04.02.2012 10:53:50

Hallo Matthias,

Dein Tipp hat genützt, so passt es gut für mich.

Besten Dank und Servus, Walter