zu umständlich, oder?

Hallo,
hab mir ein kleines Makro geschrieben, kann mir aber nicht helfen, glaube es ist ziemlich umständlich...oder was meint Ihr dazu?
Folgendes war mein Problem, habe eine Excel-Mappe die 12 Tabellenblätter enthält.
In jedem Tabellenblatt sind teilweise die gleichen Merkmale, können aber auch unterschiedlich viele Merkmale enthalten sein. Jedes Merkmal wird gekennzeichnet mit einer eindeutigen Nummer, sprich das Merkmal 10 in dem Tabellenblatt 1 ist das gleiche Merkmal wie in Tabellenblatt 2, wenn vorhanden.
Die Nummern stehen immer in der Spalte A allerdings nicht hintereinander, auch nicht sortiert, sind teilweise sehr viel leere Zeilen dazwischen bevor dann die nächste Nummer zu finden ist. Das Problem ist auch, daß es vorkommen kann, daß in Tabellenblatt 1-3 gleich viele Merkmale sind, dann ab Tabellenblatt 4 werden es mehr.
Nun brauche ich über die kompletten 12 Tabellenblätter eine vollzählige Auflistung sortiert, über alle Nummern die hier vorkommen. Die Nummern sind auch nicht aufsteigend, also wenn die 1. zu findente Nummer 10 ist, ist die zweite 20, dann vielleicht 21 oder 50 ganz unterschiedlich.
Hier mein Programm:
Option Explicit
Sub AnzahlMerkmale() Dim AM() As Long, j As Long, k As Long Dim i As Byte, l As Byte Dim Start As Double Dim m As Date 'Reservierung von 500 Werte ReDim AM(500) Start = Timer Debug.Print " gestartet um: " & Format(Now - m, "hh:mm:ss") 'Januar - Dezember For i = 1 To 12 Worksheets("Ausw.-Monat " & i).Select If i = 1 Then 'alle bewerteten Merkmale in Monat 1 erfassen um eine Basis zu schaffen For j = 1 To Range("A65536").End(xlUp).Row If Cells(j, 1) <> "" Then k = k + 1: AM(k) = Cells(j, 1) Next j Else 'ab Monat 2 überprüfen, ob weitere Merkmale hinzugekommen sind, wenn ja, diese dann hinzufügen For j = 1 To Range("A65536").End(xlUp).Row If Cells(j, 1) <> "" Then For l = 1 To k If Cells(j, 1) = AM(l) Then Exit For Next l If l > k Then k = k + 1: AM(k) = Cells(j, 1) End If Next j End If Next i 'wechseln zu leere Excelmappe indem sich auch das Makro befindet Windows("Merkmalerfassung.xls").Activate 'erfasste Merkmale sortieren For j = 1 To k Cells(j, 1) = AM(j) Next j Columns("A:A").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal 'Datenfeld löschen und auf benötigte Anzahl dimensionieren ReDim AM(k) 'erneutes Einlesen der sortierten Merkmale For j = 1 To k AM(j) = Cells(j, 1) Next j Debug.Print " beendet um: " & Format(Now - j, "hh:mm:ss") Debug.Print Format(Timer - Start, "#0.00") & " Sekunden gerödelt!" End Sub
Schönen Gruß
Sophie

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sonja,
so arg umständlich ist das Makro nicht. Was man evtl. umstellen kann:
1. Die gefundenen Werte direkt in die Tabelle in der Datei "Merkmalerfassung.xls" schreiben
2. Die For-Next-Schleife, die prüft ob in den Monaten 2-12 ein neues Merkmal gefunden wurde, durch die Find-Methode zu ersetzen. Diese ist deutlich schneller als die Suche per For-Next. Dies wirkt sich aber erst bei sehr vielen Datenzeilen nennenswert in der Laufzeit des Makros aus.
3. Entfernen der "Select" und Verwendung von entsprechenden Objektvariablen.
Das erneute einlesen der Merkmale am Schluss des Makros ist auch nicht unbedingt notwendig, es sei denn du willst damit noch irgendetwas machen. Du kannst alternativ auch direkt die Daten in dem Bereich anprechen ohne ein Array anzulegen.
Gruss
Franz
Hier mal ungetestet dein Makro entsprechend umgeformt. Dabei bin ich davon ausgegangen, dass du das Makro von der Datei aus startest, in der die 12 Auswertungsblätter sind.


Option Explicit
Sub AnzahlMerkmale()
Dim AM() As Long, j As Long, k As Long
Dim i As Byte, l As Byte
Dim Start As Double
Dim m As Date
Dim wbMerk As Workbook, wksMerk As Worksheet, wbAusw As Workbook, wksAusw As Worksheet
Dim Zelle As Range
Set wbAusw = ActiveWorkbook
Set wbMerk = Workbooks("Merkmalerfassung.xls")
Set wksMerk = wbMerk.Worksheets(1) '1 ggf. anpassen oder durch Tabellennamen in Anführungszeichen ersetzen
Start = Timer
Debug.Print " gestartet um: " & Format(Now - m, "hh:mm:ss")
'Januar - Dezember
For i = 1 To 12
Set wksAusw = wbAusw.Worksheets("Ausw.-Monat " & i)
With wksAusw
If i = 1 Then
'alle bewerteten Merkmale in Monat 1 erfassen um eine Basis zu schaffen
For j = 1 To .Range("A65536").End(xlUp).Row
If .Cells(j, 1) <> "" Then k = k + 1: wksMerk.Cells(k, 1) = .Cells(j, 1)
Next j
Else
'ab Monat 2 überprüfen, ob weitere Merkmale hinzugekommen sind, wenn ja, diese dann hinzufügen
For j = 1 To .Range("A65536").End(xlUp).Row
If .Cells(j, 1) <> "" Then
Set Zelle = wksMerk.Range("A:A").Find(what:=.Cells(j, 1), LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
k = k + 1
wksMerk.Cells(k, 1) = .Cells(j, 1)
End If
End If
Next j
End If
End With
Next i
'wechseln zu leere Excelmappe indem sich auch das Makro befindet
wbMerk.Activate
'erfasste Merkmale sortieren
With wksMerk
.Columns("A:A").Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Datenfeld löschen und auf benötigte Anzahl dimensionieren
ReDim AM(k)
'erneutes Einlesen der sortierten Merkmale
For j = 1 To k
AM(j) = .Cells(j, 1)
Next j
End With
Debug.Print " beendet um: " & Format(Now - j, "hh:mm:ss")
Debug.Print Format(Timer - Start, "#0.00") & " Sekunden gerödelt!"
End Sub

Beliebteste Forumthreads (12 Monate)

	A	B	C
1	Hilfsspalte		Ergebnisspalte
2	4		4
3	4		5
4	5		10
5	5		18
6	10		22
7	10		36
8	10		47
9	18		52
10	22		53
11	22		72
12	36
13	36
14	47
15	52
16	53
17	72
18

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread