Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1344to1348
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

Code für mehere Blätter ausdehnen

Code für mehere Blätter ausdehnen
04.02.2014 13:53:06
Gregor
Hallo zusammen
Im Forum habe ich von fcs den folgenden Supercode erhalten. Nun möchte ich diesen mit einem Makro auf mehrere Blätter anwenden. Ich versuchte es mit For Start = 1 To Sheets.Count und Next (Set wks = Sheets(Start), aber der Code funktioniert immer nur für ein Blatt. Wie geht das?
Danke und Gruss
Gregor
Sub MakeMaxList_2()
Dim wks As Worksheet
Dim Zei_1 As Long, Zei_L As Long
Dim Spa_1 As Long, Spa_L As Long, Spa_Wert As Long
Dim Spa_AD As Long, Zei_AD As Long
Dim objCol As New Collection
Dim rng_AD As Range, rngZelle As Range
On Error GoTo Fehler
Set wks = ActiveSheet 'Activeworkbook.WorkSheets("Muster")
With wks
'Zeilen und Spaltenwerte setzen/berechnen -  Werte ggf. anpassen
Zei_1 = 4 '1. Zeile mit Werten
Zei_L = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte zeile mit Werten
Spa_1 = 2 'Spalte B - 1. Spalte mit Werten
Spa_L = 5 'Spalte E - letzte Spalte mit Werten
Spa_Wert = Spa_L + 1 ' Spalte F - Spalte mit Längenwerten
Spa_AD = Spa_Wert + 1 'Spalte G - Spalte mit vorkommenden Werten
'alte Ergebnisse löschen
Zei_AD = .Cells(.Rows.Count, Spa_AD).End(xlUp).Row
If Zei_AD >= Zei_1 Then
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD + 1))
.ClearContents
.Offset(1, 0).ClearFormats
End With
End If
'vorhandene Werte in Spalte ABCD eintragen
Set rng_AD = .Range(.Cells(Zei_1, Spa_1), .Cells(Zei_L, Spa_L))
Zei_AD = Zei_1 - 1
For Each rngZelle In rng_AD.Cells
If rngZelle  "" Then
objCol.Add Item:=rngZelle.Value, Key:=Str(rngZelle.Value)
Zei_AD = Zei_AD + 1
.Cells(Zei_AD, Spa_AD) = rngZelle.Value
End If
ResumeNextCol:
Next
If Zei_AD > Zei_1 Then
'vorhandene Werte in Spalte ABCD formatieren und sortieren
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD))
.Cells(1, 1).Copy
.PasteSpecial xlPasteFormats
.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
End With
End If
If Zei_AD >= Zei_1 Then
'Formel zur Berechnung des Max-Wertes einfügen
.Cells(Zei_1, Spa_AD + 1).FormulaArray = "=MAX(IF(" _
& rng_AD.Address(ReferenceStyle:=xlR1C1) & "= RC[-1]," _
& .Range(.Cells(Zei_1, Spa_Wert), .Cells(Zei_L, Spa_Wert)) _
.Address(ReferenceStyle:=xlR1C1) & ",0))"
If Zei_AD > Zei_1 Then
'Formel zur Berechnung der Max-Werte kopieren
.Cells(Zei_1, Spa_AD + 1).Copy .Range(.Cells(Zei_1 + 1, Spa_AD + 1), _
.Cells(Zei_AD, Spa_AD + 1))
End If
'Formeln durch Werte erstzen
With .Range(.Cells(Zei_1, Spa_AD + 1), .Cells(Zei_AD, Spa_AD + 1))
.Value = .Value
End With
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'gleicher Wert soll nochmals der Collection hinzugefügt werden
Resume ResumeNextCol
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, "Fehler Makro-MakeMaxList"
End Select
End With
End Sub

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code für mehere Blätter ausdehnen
04.02.2014 13:59:21
EtoPHG
Hallo Gregor,
Ersetze:
  Set wks = ActiveSheet 'Activeworkbook.WorkSheets("Muster")
With wks

durch:
  For each wks in Thisworkbook.Worksheets


und
    End With

durch:
    Next wks
Gruess Hansueli

AW: Code für mehere Blätter ausdehnen
04.02.2014 14:18:42
Gregor
Hallo Hansueli
Geht leider nicht.
Set wks = ActiveSheet 'Activeworkbook.WorkSheets("Muster")
With wks
habe ich ausgeklammer und mit
"For each wks in Thisworkbook.Worksheets"
ersetzt.
End With vor Fehler habe ich ebenfalls ausgeklammert und vor End Sub "Next wks" hizugefügt.
Enweder gibt es bei den .Cells oder .Range eine Fehlermeldung oder wenn ich die Punkte lösche läuft zwar der Code aber passiert gar nichts.
Was läuft falsch?
Danke und Gruss
Gregor

Anzeige
AW: Code für mehere Blätter ausdehnen
04.02.2014 14:26:21
EtoPHG
Hallo Gregor,
Uups, klar.
Ersetzte jeden beginnende freistehenden . durch wks.
Beispiele:
Zei_AD = .Cells(.Rows.Count, Spa_AD).End(xlUp).Row
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD + 1))
durch:
Zei_AD = wks.Cells(wks.Rows.Count, Spa_AD).End(xlUp).Row
With wks.Range(.Cells(Zei_1, Spa_AD), wks.Cells(Zei_AD, Spa_AD + 1))
Gruess Hansueli

...und noch ein uups,
04.02.2014 14:28:38
EtoPHG
Gregor,
Fehlende Referenz im Beispiel von vorher:
Zei_AD = wks.Cells(wks.Rows.Count, Spa_AD).End(xlUp).Row
With wks.Range(wks.Cells(Zei_1, Spa_AD), wks.Cells(Zei_AD, Spa_AD + 1))
Gruess Hansueli

Anzeige
Brauch
04.02.2014 14:33:24
Jack_d
er eigentlich nicht.
denn die WKS-Schleife steht ja ausserhalb des With´s somit referiert der immer auf das jeweilig WKS
und FCS wird die referenzierung innerhalb ja bestimmt richtig gemacht haben =)
Grüße

AW: Code für mehere Blätter ausdehnen
04.02.2014 14:01:33
Jack_d
wie wär es denn mit
For Each wks In ActiveWorkbook.Worksheets 

und am ende (vor Fehler:)
next wks 

nicht vergessen
Grüße

AW: Code für mehere Blätter ausdehnen
04.02.2014 14:24:02
Gregor
Hallo
Auch das geht nicht, es wird nur das erste Blatt ausgefüllt.
Gruss Gregor

AW: Code für mehere Blätter ausdehnen
04.02.2014 14:31:50
Jack_d
Ich Weiss nicht wo du es eingefügt hast, aber bei mir läuft der Code über alle Blätter
Sub MakeMaxList_2()
Dim wks As Worksheet
Dim Zei_1 As Long, Zei_L As Long
Dim Spa_1 As Long, Spa_L As Long, Spa_Wert As Long
Dim Spa_AD As Long, Zei_AD As Long
Dim objCol As New Collection
Dim rng_AD As Range, rngZelle As Range
On Error GoTo Fehler
For Each wks In ActiveWorkbook.Worksheets
With wks
'Zeilen und Spaltenwerte setzen/berechnen -  Werte ggf. anpassen
Zei_1 = 4 '1. Zeile mit Werten
Zei_L = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte zeile mit Werten
Spa_1 = 2 'Spalte B - 1. Spalte mit Werten
Spa_L = 5 'Spalte E - letzte Spalte mit Werten
Spa_Wert = Spa_L + 1 ' Spalte F - Spalte mit Längenwerten
Spa_AD = Spa_Wert + 1 'Spalte G - Spalte mit vorkommenden Werten
'alte Ergebnisse löschen
Zei_AD = .Cells(.Rows.Count, Spa_AD).End(xlUp).Row
If Zei_AD >= Zei_1 Then
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD + 1))
.ClearContents
.Offset(1, 0).ClearFormats
End With
End If
'vorhandene Werte in Spalte ABCD eintragen
Set rng_AD = .Range(.Cells(Zei_1, Spa_1), .Cells(Zei_L, Spa_L))
Zei_AD = Zei_1 - 1
For Each rngZelle In rng_AD.Cells
If rngZelle  "" Then
objCol.Add Item:=rngZelle.Value, Key:=Str(rngZelle.Value)
Zei_AD = Zei_AD + 1
.Cells(Zei_AD, Spa_AD) = rngZelle.Value
End If
ResumeNextCol:
Next
If Zei_AD > Zei_1 Then
'vorhandene Werte in Spalte ABCD formatieren und sortieren
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD))
.Cells(1, 1).Copy
.PasteSpecial xlPasteFormats
.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
End With
End If
If Zei_AD >= Zei_1 Then
'Formel zur Berechnung des Max-Wertes einfügen
.Cells(Zei_1, Spa_AD + 1).FormulaArray = "=MAX(IF(" _
& rng_AD.Address(ReferenceStyle:=xlR1C1) & "= RC[-1]," _
& .Range(.Cells(Zei_1, Spa_Wert), .Cells(Zei_L, Spa_Wert)) _
.Address(ReferenceStyle:=xlR1C1) & ",0))"
If Zei_AD > Zei_1 Then
'Formel zur Berechnung der Max-Werte kopieren
.Cells(Zei_1, Spa_AD + 1).Copy .Range(.Cells(Zei_1 + 1, Spa_AD + 1), _
.Cells(Zei_AD, Spa_AD + 1))
End If
'Formeln durch Werte erstzen
With .Range(.Cells(Zei_1, Spa_AD + 1), .Cells(Zei_AD, Spa_AD + 1))
.Value = .Value
End With
End If
End With
Next wks
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'gleicher Wert soll nochmals der Collection hinzugefügt werden
Resume ResumeNextCol
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, "Fehler Makro-MakeMaxList"
End Select
End With
End Sub

Anzeige
Einfacher,
04.02.2014 14:31:44
EtoPHG
und nochmals hallo,
Ersetze:
Set wks = ActiveSheet 'Activeworkbook.WorkSheets("Muster")

Durch:

For each wks in Thisworkbook.Worksheets

und füge nach:
   End With

ein:
   End With
Next wks
...dann brauchst du die . nicht mit wks. zu ersetzen.
Gruess Hansueli

AW: Einfacher,
04.02.2014 14:49:26
Gregor
Hallo zusammen
Es funtioniert auf keine Art. Ich erlaube mir, die Musterdatei
https://www.herber.de/bbs/user/89095.xlsm
nochmals hochzuladen, evt. ist dann der Fehler erkennbar.
Danke und Gruss
Gregor

Anzeige
Collection nicht resetiert,
04.02.2014 14:59:12
EtoPHG
Hallo Gregor,
Setze vor die Zeile Next wks noch:
       Set objCol = Nothing
Gruess Hansueli

Oder so
04.02.2014 15:05:50
Jack_d
ich hab auch an sowas gedacht, aber leider nix passendes gefunden :-D

AW: Oder so
04.02.2014 16:21:34
fcs
Hallo Gregor,
das Reset des Collection-Objects in der Schleife ist der korrekte Weg.
Dazu den Anfang des Makros wie folgt anpassen:
Sub MakeMaxList_fcs()
Dim wks As Worksheet
Dim Zei_1 As Long, Zei_L As Long
Dim Spa_1 As Long, Spa_L As Long, Spa_Wert As Long
Dim Spa_AD As Long, Zei_AD As Long
Dim objCol As Collection                'geändert
Dim rng_AD As Range, rngZelle As Range
On Error GoTo Fehler
For Each wks In ThisWorkbook.Worksheets
'  Set wks = ActiveSheet 'Activeworkbook.WorkSheets("Muster")
Set objCol = New Collection             'neue Zeile
With wks
Gruß
Franz

Anzeige
Für FCS mal zum nachschauen
04.02.2014 15:04:31
Jack_d
Hallo Gregor
Es Funktioniert schon
Er springt durch alle Blätter
Ich hab aber was interessantes gefunden.
Das das Makro funktioniert wenn die Zahlen nicht identisch zu den Zahlen des 1. Blattes sind.
Am besten durch klärst das mit fcs
der hat den Code entwicklt und kennt genau den Ablauf darin.
Für ihn wahrscheinlich eher eine Fingerübung.
Grüße

AW: Für FCS mal zum nachschauen
04.02.2014 16:38:07
Gregor
Hallo an alle
Ja, so funktioniert es für alle Blätter. Ich habe testhalber natürlich nur die Blätter kopiert, deshalb die identischen Zahlen. Bei der Scharfschlatung sind natürlich alle Zahlen unterschiedlich. Offenbar hätte das dann funktioniert. So oder so, vielen Dank für die Unterstützung.
Beste Grüsse
Gregor
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige