Frage von molekuelx, 82

VBA: Wie kann ich den Code kürzen?

Hallo Zusammen,

ich habe ein Anliegen. Zum einen würde ich gerne den Teil am ende eleganter lösen. Anstatt den drei Pünktchen habe ich alle funktionen zwischen dem Anfang und dem Ende durchformuliert. Ich habe jeweils nur die ersten 3 und die letzen 3 darstehen lassen.

Sub vergleich()
   Application.EnableEvents = False
   Application.ScreenUpdating = False
 
   gl = True
   
   For sp = 0 To 4
      sp1 = 3 + sp
      sp2 = 4 + sp
      For ze = 0 To 148
         ze1 = 6 + ze
         ze2 = 2 + ze
         
         v1 = Sheets(1).Cells(ze1, sp1)
         v2 = Sheets(5).Cells(ze2, sp2)
         
         c1 = True
         c2 = True
      
         If (v1 = v2) Then
            c1 = False
            c2 = False
         End If
      
         If (v1 = "") Then
            c1 = False
         End If
         
         If (v2 = "") Then
            c2 = False
         End If
         
         If (c1 = True) Then
            gl = False
            Sheets(1).Cells(ze1, sp1).Interior.Color = RGB(255, 255, 0)
         Else
            Sheets(1).Cells(ze1, sp1).Interior.Color = xlNone
         End If
 
         If (c2 = True) Then
            gl = False
            Sheets(5).Cells(ze2, sp2).Interior.Color = RGB(255, 255, 0)
         Else
            Sheets(5).Cells(ze2, sp2).Interior.Color = xlNone
         End If
               
      Next
   Next
    If gl = True Then Sheets(1).Cells(6, 18) = Sheets(5).Cells(2, 40) Else Sheets(1).Cells(6, 18) = Sheets(1).Cells(6, 18)
    If gl = True Then Sheets(1).Cells(7, 18) = Sheets(5).Cells(3, 40) Else Sheets(1).Cells(7, 18) = Sheets(1).Cells(7, 18)
    If gl = True Then Sheets(1).Cells(8, 18) = Sheets(5).Cells(4, 40) Else Sheets(1).Cells(8, 18) = Sheets(1).Cells(8, 18)


…


    If gl = True Then Sheets(1).Cells(148, 18) = Sheets(5).Cells(144, 40) Else Sheets(1).Cells(148, 18) = Sheets(1).Cells(148, 18)
    If gl = True Then Sheets(1).Cells(149, 18) = Sheets(5).Cells(145, 40) Else Sheets(1).Cells(149, 18) = Sheets(1).Cells(149, 18)
    If gl = True Then Sheets(1).Cells(150, 18) = Sheets(5).Cells(146, 40) Else Sheets(1).Cells(150, 18) = Sheets(1).Cells(150, 18)
   
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

Vielen Dank für die Hilfe

Expertenantwort
von Iamiam, Community-Experte für Excel, 38
dim i '(nicht essentiell: As Integer, das oben noch einfügen, sowie:) 
On Error Goto NormalZustandWiederHerstellen
'...
If gl = True Then
For i = 1 to 243
Sheets(1).Cells(i+5, 18) = Sheets(5).Cells(i+1, 40)
next
Else Sheets(1).Cells(i+5, 18) = Sheets(1).Cells(i+5, 18) 'kann genausogut fehlen, ändert ja nix, oder setzt du da eine Formel zu Wert um?
End if
'...Spar Dir übrigens nicht das Standardargument .value, du siehst, dass es zu Unsicherheiten führt, wenn es fehlt (könnte ja auch mal .formula oder formulalocal gemeint sein oder Anderes
'vor Appl. Enable usw unbedingt noch einfügen: (der : bedeutet Zeilenmarke!)

NormalZustandWiederHerstellen
:


Kommentar von Iamiam ,

stelle auch die Option Explicit ein und melde alle Variablen per dim an, dieser kleine Aufwand erleichtert die Fehlerursachen zu finden enorm! Das jeweilige As ... braucht VBA bei den heutigen Kapazitäten nicht mehr, da wird eben dann eine max. Variable angemeldet und dafür der Speicherplatz reserviert.

Objekte musst Du dann per Set definieren, Matritzen als dim Mtx() voranmelden  und dann als Einsatz als redim Mtx(3, 4) als  hier zB 12-Item-Matrix festlegen.

Für eine Inputbox, die Adressen-Eingaben verarbeiten soll (muss meist nicht als Matrix angemeldet werden, weil VBA das ja als Bereich versteht, der schon im Blatt angelegt, also vorhanden ist und nur ausgewählt werden muss):

Set FeldA = inputbox(...........;8) -Typ wählen und alle ; setzen

(das waren die Hürden, die mich seinerzeit am meisten Zeit gekostet haben und dabei ganz einfach zu überwinden sind, wenn man weiß, wie!)

Kommentar von Iamiam ,

drittletzte Zeile: Kann sogar sein, dass da noch ein Application. vor das Inputbox muss, das kann ich mir nie merken, wann das rein muss und wann nicht (zB bei Application.Worksheetfunction zB muss es rein! in anderen Fällen kanns überflüssig oder sogar störend sein!)

Kommentar von Suboptimierer ,

Ich hatte schon ähnliche Phänomene, kann dieses aber momentan nicht nachvollziehen.

Sowohl Prozeduren direkt am Sheet als auch die eines Moduls lassen sich ohne Application-Präfix ausführen:

Sheet:

Sub ApplicationTest1()
  Sheets(1).Range("D1").Value = WorksheetFunction.Max(1, 5, 3)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$D$1" Then _ Sheets(1).Range("D1").Value = WorksheetFunction.Max(2, 6, 4) End Sub

Modul:

Sub ApplicationTest2()
  Sheets(1).Range("D1").Value = WorksheetFunction.Max(3, 7, 9)
End Sub
Kommentar von Iamiam ,

danke für den Hinweis!

Expertenantwort
von Suboptimierer, Community-Experte für Excel, 36

Ich konzentriere mich mal auf die Stelle mit den Pünktchen. Um die geht es dir ja.

  1. Statt "If gl = True" reicht "If gl"
  2. Du kannst alle If gl-Abfragen in einen Block zusammenfassen: 

    If gl Then
     '...
    End If
  3. Das Else kannst du, wie geri3d schreibt, sparen, da du jeweils eine Zelle auf sich selbst abbildest.
  4. Du zählst beim Zuweisen immer um 1 hoch, also kannst du eine Schleife benutzen.

    For i=6 To 150
      Sheets(1).Cells(i,18).Value = Sheets(5).Cells(i-4,40).Value
    Next

Zusatzhinweis: Auf Application.EnableEvents = False sollte immer ein On Error GoTo folgen, damit sichergestellt ist, dass Excel nicht lahm gelegt wird.



Kommentar von molekuelx ,

Vielen Dank, super Erklärung! bin auf das i-4 nicht selbst gekommen, scheint aber einwandfrei zu funktionieren.

Ich habe jetzt noch "On Error GoTo Fehler" eingefügt und eine Message Box eingefügt. Leider kommt die jetzt bei jedem Durchlauf und nicht nur wenn er den Kopiervorgang nicht durchführt.

Wo liegt da der Fehler ?

 

    If gl Then
        For i = 6 To 150
            Sheets(1).Cells(i, 18).Value = Sheets(5).Cells(i - 4, 40).Value
        Next
    End If
     
   Application.EnableEvents = True
   Application.ScreenUpdating = True
 On Error GoTo Fehler
Fehler:
   MsgBox "Error"
Kommentar von Suboptimierer ,

Vor "Fehler:" würde ich mit "Exit Sub" aus der Prozedur aussteigen.

On Error GoTo Fehler sollte hinter ...EnableEvents = False stehen, also oben, nicht nach dem Aktivieren.

Unter der MsgBox solltest du die Fehlerbehandlung wieder ausstellen: On Error GoTo 0

Nochmal zusammengefasst:

Application.EnableEvents = False
On Error GoTo Fehler
'...
Application.EnableEvents = True
On Error GoTo 0
Exit Sub
Fehler:
Application.EnableEvents = True
MsgBox "Fehler"
On Error GoTo 0

Ohne Meldung wäre es einfacher:

Application.EnableEvents = False
On Error GoTo Fehler
'...
Fehler:
Application.EnableEvents = True
On Error GoTo 0

(alles ungetestet)

Kommentar von molekuelx ,

Danke für die hilfreichen Beiträge! Das hilft mir sehr dabei, VBA Stück für Stück besser zu verstehen und zu lernen! Habe die Fehlermeldung erfolfreich eingebaut :-)

Zwei kleine Punkte sind jedoch noch offen und wollen einfach nicht funktionieren.

1. Der Komplette vergleich mit anschließendem kopieren und einfügen soll nur erfolgen, wenn ein Button angeklickt wird. Dazu habe ich ein Formularsteuerelement eingefügt (bei ActiveX kommt immer eine Fehlermeldung) und habe der Schaltfläche das Makro zu gewiesen. Das funktioniert auch prima! Jedoch löst das Makro auch vor einem Rechtsklick aus (da Code von Tabelle 1 und 2 so eingestellt ist " Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)"

---> Welches Ereigniss muss ich verwenden, damit das Makro nur vom Formularsteuerelement ausgelößt wird, und nicht bei change oder beforrightklick etc ... ?

 

2. Zudem soll nur in Tabelle 1 ein zusätzlicher Befehl ausgeführt werden, wenn der Status kopiert und eingefügt wird. (also nicht bei gl=False sondern nur bei If gl then)

Wenn ich den unten stehenden Code jedoch hinzufüg kommt zwar keine Fehlermeldung, es passiert aber auch nichts.

Der Code der in der Tabelle 1 schon steht ist folgender:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  Call DieseArbeitsmappe.vergleich
End Sub

Der Code der in Tabelle 1 ergänzt werden soll ist dieser:

Private Sub Worksheet_Change(ByVal Target As Range)
  'Abfrage, ob Änderung in Spalte R erfolgt ist
  Dim i As Integer
  For i = 6 To 150
    If Target.Address = "$R$" & i Then
        If Target.Value = "STATUS1=grün" Then
            Range("I" & i & ":J" & i).ClearContents
            Range("L" & i & ":N" & i).ClearContents
        End If
        If Target.Value = "STATUS2=gelb" Then
            Range("I" & i & ":J" & i).ClearContents
        End If
    End If
  Next
End Sub

 

Danke für die Unterstützung!!!

Kommentar von Suboptimierer ,

1) Leg ein Modul an (Einfügen → Modul). Leg dort eine Prozedur an (Sub Vergleich()). Weis dem Formularsteuerelement "Schaltfläche" das Makro "Vergleich" zu (rechte Maustaste → Makro zuweisen...). Kopier den Code in die Prozedur Vergleich.

Es werden noch Anpassungen fällig sein. Du hast kein Zugriff mehr auf Target und musst manuell die Bezugszelle festlegen.
Es kann sein, dass du das Sheet, auf das du dich beziehst, vor jedem Range-Befehl explizit angeben musst.

2) 

If gl Then
  ' Zusätzlicher Befehl
End If
Kommentar von molekuelx ,

Habe jetzt die ganze "Prozedur" in einem Modul1 abgelegt und den Code schnippsel zusätzlich eingefügt.

Jetzt bringt er aber: "Fehler beim Kompilieren: Mehrfachdeklaration im aktuellen Gültigkeitsbereich" und verweist auf den Befehel: "Dim i As Integer"

Habe gegoogelt, finde bei mir aber nur diese Deklaration einmal und nicht doppelt?

Das Ende des Codes im Modul sieht jetzt so aus:

...
         If (c2 = True) Then
            gl = False
            Sheets(5).Cells(ze2, sp2).Interior.Color = RGB(0, 255, 255)
         Else
            Sheets(5).Cells(ze2, sp2).Interior.Color = xlNone
         End If
              
      Next
   Next
  
    If gl Then
        For i = 6 To 150
            Sheets(1).Cells(i, 18).Value = Sheets(5).Cells(i - 4, 40).Value
            Sheets(1).Cells(i, 17).Value = Sheets(5).Cells(i - 4, 23).Value
            Sheets(1).Cells(i, 16).Value = Sheets(5).Cells(i - 4, 25).Value
        Next
    End If
     
     
    If gl Then
   
    Dim i As Integer
    For i = 6 To 150
    If Target.Address = "$R$" & i Then
        If Target.Value = "STATUS1=grün" Then
            Range("I" & i & ":J" & i).ClearContents
            Range("L" & i & ":N" & i).ClearContents
        End If
        If Target.Value = "STATUS2=gelb" Then
            Range("I" & i & ":J" & i).ClearContents
        End If
    End If
  End If
       
       
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

Der Code der bei Tabelle 1 und 5 hinterlegt ist, ist aber immer noch gleich:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  Call DieseArbeitsmappe.vergleich
End Sub

Müsste man dort nicht etwas wegen dem BeforeRightClick ändern?

 

 

Kommentar von Suboptimierer ,

Ich sehe auch nur einmal Dim i. i wird jedoch davor schon verwendet. Du solltest die Deklarationen an den Anfang der Prozedur stellen. Was steht denn bei ...?

If gl Then   
    Dim i As Integer
    For i = 6 To 150
Kommentar von molekuelx ,
Sub vergleich()
   Application.EnableEvents = False
   Application.ScreenUpdating = False
 
   gl = True
  
   For sp = 0 To 4
      sp1 = 3 + sp
      sp2 = 4 + sp
      For ze = 0 To 148
         ze1 = 6 + ze
         ze2 = 2 + ze
        
         v1 = Sheets(1).Cells(ze1, sp1)
         v2 = Sheets(5).Cells(ze2, sp2)
        
         c1 = True
         c2 = True
     
         If (v1 = v2) Then
            c1 = False
            c2 = False
         End If
     
         If (v1 = "") Then
            c1 = False
         End If
        
         If (v2 = "") Then
            c2 = False
         End If
        
         If (c1 = True) Then
            gl = False
            Sheets(1).Cells(ze1, sp1).Interior.Color = RGB(0, 255, 255)
            MsgBox "ERROR: Status Abgleich Fehlgeschlagen."
         Else
            Sheets(1).Cells(ze1, sp1).Interior.Color = xlNone
         End If
 
         If (c2 = True) Then
            gl = False
            Sheets(5).Cells(ze2, sp2).Interior.Color = RGB(0, 255, 255)
         Else
            Sheets(5).Cells(ze2, sp2).Interior.Color = xlNone
         End If
              
      Next
   Next
  
    If gl Then
        For i = 6 To 150
            Sheets(1).Cells(i, 18).Value = Sheets(5).Cells(i - 4, 40).Value
            Sheets(1).Cells(i, 17).Value = Sheets(5).Cells(i - 4, 23).Value
            Sheets(1).Cells(i, 16).Value = Sheets(5).Cells(i - 4, 25).Value
        Next
    End If
     
     
    If gl Then
   
    Dim i As Integer
    For i = 6 To 150
    If Target.Address = "$R$" & i Then
        If Target.Value = "STATUS1=grün" Then
            Range("I" & i & ":J" & i).ClearContents
            Range("L" & i & ":N" & i).ClearContents
        End If
        If Target.Value = "STATUS2=gelb" Then
            Range("I" & i & ":J" & i).ClearContents
        End If
    End If
  End If
       
       
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

 

Das ist der komplette Code im Modul1

Kommentar von Suboptimierer ,

Dim i muss an den Anfang. Es darf keine zweite Prozedur namens "Vergleich" geben.

Schreibe oben, in die allererste Zeile (außerhalb der Prozeduren) "Option Explicit". Das sollte deine Fehlersuche erleichtern.

Kommentar von molekuelx ,

Habe das so abgeändert. Jetzt meldet er: "Fehler beim Kompilieren: Variable nicht definiert" und verweist auf gl=True ganz am anfang der Prozedur.

Seltsam, das es ja bis dato den Code nicht gestrört hatte

Kommentar von Suboptimierer ,

Ja, genau das bewirkt Option Explicit. So wird dein Quellcode sauberer. Schreibe am Anfang der Prozedur Dim gl As Boolean und verfahre mit den folgenden Fehlern genau so.

Kommentar von molekuelx ,

Danke für deine Geduld! Ich steige langsam durch :-) 

Ich bin jedoch noch unsicher, als was ich Target deklarieren soll? Habe provisorisch mal "Dim Target As Action" eingefügt, dass er nicht mehr meckert.

--> Beim Ausführen kommt jetzt "Laufzeitfehler 13: Typen unverträglichkeit" und er verweist auf v1=Sheets(1).Cells(ze1, sp1)

Ich gehe davon aus, dass er mit dem "Ziel" bzw. Target nicht weis was er anfangen soll, kann das sein?

Sub vergleich()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim i As Integer
Dim gl As Boolean

Dim sp As Integer
Dim sp1 As Integer
Dim sp2 As Integer

Dim ze As Integer
Dim ze1 As Integer
Dim ze2 As Integer

Dim c1 As Boolean
Dim c2 As Boolean

Dim v1 As Integer
Dim v2 As Integer

Dim Target As Action


gl = True

For sp = 0 To 4
sp1 = 3 + sp
sp2 = 4 + sp
For ze = 0 To 148
ze1 = 6 + ze
ze2 = 2 + ze

v1 = Sheets(1).Cells(ze1, sp1)
v2 = Sheets(5).Cells(ze2, sp2)

c1 = True
c2 = True

If (v1 = v2) Then
c1 = False
c2 = False
End If

If (v1 = "") Then
c1 = False
End If

If (v2 = "") Then
c2 = False
End If

If (c1 = True) Then
gl = False
Sheets(1).Cells(ze1, sp1).Interior.Color = RGB(0, 255, 255)
MsgBox "ERROR: Fehler."
Else
Sheets(1).Cells(ze1, sp1).Interior.Color = xlNone
End If

If (c2 = True) Then
gl = False
Sheets(5).Cells(ze2, sp2).Interior.Color = RGB(0, 255, 255)
Else
Sheets(5).Cells(ze2, sp2).Interior.Color = xlNone
End If

Next
Next

If gl Then
For i = 6 To 150
Sheets(1).Cells(i, 18).Value = Sheets(5).Cells(i - 4, 40).Value
Sheets(1).Cells(i, 17).Value = Sheets(5).Cells(i - 4, 23).Value
Sheets(1).Cells(i, 16).Value = Sheets(5).Cells(i - 4, 25).Value
Next
End If

If gl Then
For i = 6 To 150
If Target.Address = "$R$" & i Then
If Target.Value = "STATUS1=grün" Then
Range("I" & i & ":J" & i).ClearContents
Range("L" & i & ":N" & i).ClearContents
End If
If Target.Value = "STATUS2=gelb" Then
Range("I" & i & ":J" & i).ClearContents
End If

End If

Application.EnableEvents = True
Application.ScreenUpdating = True

Next
End If
End Sub
Kommentar von Suboptimierer ,

Target, v1 und v2 sind vom Typ Range. Target würde ich umbenennen, um nicht Verwirrung zu stiften, denn Target wird üblicherweise als Name für den Übergabeparameter eines Ereignisses verwendet.

Benenn deine Variablen allgemein sprechender. Aus dem Namen sollte der Typ bereits hervor gehen. Statt sp iSpalte (i=Integer), statt ze iZeile, ...

Du bekommst Target nicht mehr übergeben. Du musst die Zelle selbst zuordnen.

Kommentar von molekuelx ,

Sorry schnelle korrektur: Habe v1 und v2 als string deklariert und jetzt geht es :-)

Jedoch passt das mit dem Target tatsächlich nicht. Er meldet den Fehler 91: Objektvariable oder With-Blockvariable nicht festgelegt.

und markiert " If Target.Address = "$R$" & i Then"

Kommentar von Suboptimierer ,

Du hast nicht festgelegt, auf welche Zelle sich Target bezieht → Beispiel: Set Target = Sheets(1).Range("R8")

Kommentar von molekuelx ,

Habe das so eingefügt (Set Target = Sheets(1).Range("R6")), dann funktioniert das auch für R6 ...

Target ist ja aber eigentlich der ganze bereich R6:R150 nur bei folgendem Befehl tut er gar nichts:

Set Target = Sheets(1).Range("R6:R150")

und das Problem mit dem Rechtsklick bleibt bestehen da Tabelle 1 und Tabellle 5 den Code enthält:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Call DieseArbeitsmappe.vergleich
End Sub
Kommentar von Suboptimierer ,

Wenn das Target für einen Bereich gelten soll, musst du jede Zelle des Bereichs in einer Schleife durchwandern:

For Each Target in Sheets(1).Range("R6:R150")
  '...
Next

Das mit dem Rechtsklick brauchst du doch gar nicht mehr, oder? Den Code kannst du löschen. Du löst doch jetzt per Klick auf den Button aus.

Kommentar von molekuelx ,

Ok habe die Targetschleife eingefügt, es funktioniert auch aber er führt schon seit 2 Minuten das Makro aus und ist noch nicht fertig :D 

Kommentar von Suboptimierer ,
For i = 6 To 150

Das brauchst du nicht mehr. Ersetz das durch i = Target.Row oder andersherum brauchst du die For Each Schleife nicht mehr, wenn du nach For i = 6 To 150 schreibst: Set Target = Sheets(1).Range("R" & i)

Viele Wege führen nach Rom.

Kommentar von molekuelx ,

Super, jetzt braucht er "nur" noch 20 Sekunden! Das ist jedoch akzeptabel auch wenn es etwas "blinkt" und "zuckt".

Vielen Dank für deine Mühe und deine Zeit! Habe eigenständig und erfolgreich noch abschließend eine "Fehlermeldung" bei gl=False und eine "Erfolgsmeldung" bei gl=True eingefügt. Funktioniert prima und habe das konzept geschnallt :-)

Kommentar von Suboptimierer ,

Bitteschön! Der Teufel steckt oftmals im Detail.

Kommentar von molekuelx ,

Habe mit einem anderen (ähnlichen) Modul noch ein winziges Problem. Das Knackpunkt liegt nur bei ze2 ... ich finde aber ums verrecken nicht den richtigen Weg. Es funktioniert eigentlich genau so wie es soll. Jedoch soll in Sheet(2).Cells(ze2, sp3).Value der Bereich quasi ab Zeile 6 aufgefüllt werden. Im Moment kopiert er das was in Sheet1 in Zeile 40 steht in Sheet2 in Zeile 40 (da ze1=ze2) er soll aber in Sheet2 ab Zeile 6 reinkopieren und dann quasi auffüllen.

--> Kopiere in Sheet2 Zeile6 das erste "Teil". Das zweite gefundene Teil (z.B. "STATUS3=rot") soll er dann in der nächst freien Zeile kopieren also Zeile 7.

Ich hoffe es ist verständlich. Ich vermute es ist sehr einfach zu lößen in dem man ze2 anderes festlegt. Bin jedoch sehr zufrieden mit meiner Eigenleistung ;-) Aller Anfang ist schwer ...

Hier der Code um den es geht:

Option Explicit
Sub vergleich()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim sp As Integer
Dim sp1 As Integer
Dim sp2 As Integer
Dim sp3 As Integer

Dim ze As Integer
Dim ze1 As Integer
Dim ze2 As Integer

Dim v1 As String
Dim v2 As String
Dim v3 As String

Dim Target As Range

For Each Target In Sheets(1).Range("R6:R150")

For sp = 0 To 4
sp1 = 3 + sp
sp2 = 11 + sp
sp3 = 17 + sp

For ze = 0 To 148
ze1 = 6 + ze
ze2 = 1 + ze

v1 = Sheets(1).Cells(ze1, sp1)
v2 = Sheets(2).Cells(ze2, sp2)
v3 = Sheets(1).Cells(ze1, 35)

If (v3 = "STATUS2=gelb") Then
Sheets(2).Cells(ze2, sp3).Value = Sheets(1).Cells(ze1, sp1).Value
Sheets(2).Cells(ze2, 21).Value = Sheets(1).Cells(ze1, 34).Value
End If

If (v3 = "STATUS3=rot") Then
Sheets(2).Cells(ze2, sp2).Value = Sheets(1).Cells(ze1, sp1).Value
Sheets(2).Cells(ze2, 15).Value = Sheets(1).Cells(ze1, 34).Value
End If
Next
Next
Next
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
Kommentar von Suboptimierer ,

Warum der ab Zeile 40 anfängt, sehe ich nicht, aber dein For Each Target ist hier überflüssig. Du verwendest Target innerhalb der Schleife gar nicht. Andere Variablen werden auch innerhalb der For-Each-Schleife initialisiert.

Kannst du nicht einfach die Copy-Methode zum Kopieren von Zellbereichen verwenden?

Kein Wunder, dass man da schwer durch blickt, bei so vielen Variablen.

Kommentar von Suboptimierer ,

Achso, du kopierst selektiv.

Da man meistens Zeilen kopieren will, solltest du über die Zeilen in der äußeren Schleife iterieren, über die Spalten in der inneren. Ich müsste es mir genauer anschauen, aber evtl. könntest du dir die Iteration über die Spalten sparen, indem du komplette Zeilen mit Copy kopierst.

Kommentar von molekuelx ,

Das mit Zeile 40 war nur ein Beispiel :P Er tut eigentlich genau schon das war er soll ... nur er lässt in Sheet 2 zwischen den kopierten Zellen (Zeilen) immer genau so viele Platz wie auch in Sheet1 zwischen den Zeilen ist.

Bsp.: Das erste Teil (was in Sheet1 Spalte R den Inhalt: "STATUS3=rot") enthälllt soll er in Sheet2 (6 , sp2) kopieren. Also wenn das Teil in Sheet1 in Zeile bsp. 25 Steht soll er es in Sheet 2 in Zeile 6 einfügen. Das nächste Teil was er bsp. in Sheet1 Zeile 38 findet ("STATUS3=rot") soll er in Sheet2 dementsprechen in die nächste leer Zeile kopieren, also Sheet2 (7, sp2) 

Die Spalten stimmen schon Perfekt! Nur die Zeilen passen nicht.

Kommentar von Suboptimierer ,

Puh, du verstehst sicherlich, wenn das mir jetzt zu aufwändig ist, für dich alles umzuschreiben. Ich kann dir aber helfen, indem ich dir den Weg skizziere:

  • Lauf über alle Zeilen zeQuelle in der Quelltabelle
  • Setze dir einen Merker zeZiel1 auf die erste Zeile der Zieltabelle1, zeZiel2 für Zieltabelle2 usw.
  • Immer wenn nach zeZiel1 kopiert wurde, inkrementierst du zeZiel1 (zeZiel2 usw. entsprechend, wenn jene Tabellen zum Ziel werden)
  • Genauso verfährst du mit den Spalten (wenn du nicht die Zeilen in einem Rutsch mit Copy kopieren willst)
  • Wie gesagt empfehle ich, die äußere Schleife über die Zeilen laufen zu lassen. Das ist einfach üblich, da man pro Zeile von links nach rechts liest und nicht pro Spalte von oben nach unten. Wir sind doch keine Chinesen. ^^
Kommentar von Iamiam ,

Da kommt die Meldung wahrscheinlich trotzdem.  vllt:

if Err() <> 0 then Msgbox"Fehler "& Err()

?

Im übrigen finde ich die unterschiedliche Verwertung von i in unseren beiden Antworten interessant! Es führen wieder mal viele Wege nach Rom! (als i-4 würde der Bezug zu offset(-4, ...) offensichtlich!)

Antwort
von geri3d, 43

Über den Else-Zweig kann man sich streiten. Das schreit nach einer For Schleife. Ich bin mir nicht ganz klar wie das mit dem Offset ist.

 If gl = True Then Sheets(1).Cells(6, 18) = Sheets(5).Cells(2, 40) Else Sheets(1).Cells(6, 18) = Sheets(1).Cells(6, 18)

Ich will dir das jetzt nicht im code vorkauen, eine Forschleife solltest du schon noch zustande bringen.

Kommentar von Suboptimierer ,

Sagen wir es doch einmal, wie es ist. Der Else-Zweig ist sinnlos. Er weist einer Zelle den Wert zu, den sie sowieso schon trägt.

Else Sheets(1).Cells(6, 18) = Sheets(1).Cells(6, 18)
Kommentar von molekuelx ,

Ja das ist vollkommen richtig :D das war meine Lösung dafür, dass dann einfach nichts passieren soll ... ich wusste nur nicht wie ich das formulieren muss / kann

Kommentar von Suboptimierer ,

Du hättest es einfach weglassen können. -.-

Kommentar von molekuelx ,

Ich dachte mir auch, dass eine For Schleife die richtig lösung ist. Da der Befehl aber Sheet 1 und Sheet 5 beihalted, bin ich mir unsicher wie ich dem Bezug setze.

Wäre das so zu lößen?

Ich bin leider gerade erst dabei mir VBA beizubringen und versuche stück für stück zu verstehen, wie die Codes funktionieren.


Dim intRow As Integer<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" />

 

   For intRow = 6 To 150

   For intRow = 2 To 148

          If gl = True Then Sheets(1).Cells(6, 18) = Sheets(5).Cells(2, 40) Else Sheets(1).Cells(6, 18) = Sheets(1).Cells(6, 18)  

 

Next intRow

 

Kommentar von geri3d ,

Denk mal logisch. Nur wenn g1=true ansonsten brauchst du nicht mal die schleife also strukturiere deine logik um.

Keine passende Antwort gefunden?

Fragen Sie die Community

Weitere Fragen mit Antworten