Makro optimieren

Forumthread: Makro optimieren

Makro optimieren

11.01.2005 12:54:40

Heino

Hallo
Wie könnte ich folgendes Makro optimieren damit es schneller läuft ?
Das Makro sucht in der Tabelle CAQ einen Wert in der Spalte E und wenn vorhanden dann Kopiert er die Zeile in die entsprechende Tabelle.
Bin für jeden Tip Dankbar
Gruß Heino


Sub Kopieren()
' Daten werden auf die einzelnen Blätter verteilt
' Am Ende Sprung zum Doppelte Werte löschen
Dim i As Long, Zähler As Long
Dim Blatt1 As Worksheet
Dim Blatt2 As Worksheet
Set Blatt1 = ThisWorkbook.Sheets("CAQ")
Set Blatt2 = ThisWorkbook.Sheets("Endkontrolle")
Set Blatt3 = ThisWorkbook.Sheets("Tank")
Set Blatt4 = ThisWorkbook.Sheets("Schweissen")
endz = 1
tankz = 1
schwz = 1
Application.ScreenUpdating = False
For i = 1 To 15000 'Zeilenanzahl einstellen, die überprüft werden soll
If Blatt1.Range("E" & i) = "Endkontrolle" Then
endz = endz + 1
Blatt1.Select
Blatt1.Rows(i).Select
Selection.Copy
Blatt2.Select
Rows(endz).Select
ActiveSheet.Paste
End If
If Blatt1.Range("E" & i) = "Tank" Then
tankz = tankz + 1
Blatt1.Select
Blatt1.Rows(i).Select
Selection.Copy
Blatt3.Select
Rows(tankz).Select
ActiveSheet.Paste
End If
If Blatt1.Range("E" & i) = "Schweissung" Then
schwz = schwz + 1
Blatt1.Select
Blatt1.Rows(i).Select
Selection.Copy
Blatt4.Select
Rows(schwz).Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Makro optimieren

Udo
AW: Makro optimieren

Heino
AW: Makro optimieren

WernerB.
AW: Makro optimieren

Heino

AW: Makro optimieren

Udo

Konsequent auf select/activate verzichten!
Udo

AW: Makro optimieren

Heino

Danke für die Antwort
Und wie ?

AW: Makro optimieren

WernerB.

Hallo Heino,
wie gefällt Dir das (ungetestet!)?


Sub Kopieren()
' Daten werden auf die einzelnen Blätter verteilt
' Am Ende Sprung zum Doppelte Werte löschen
Dim Blatt1 As Worksheet, Blatt2 As Worksheet, _
Blatt3 As Worksheet, Blatt4 As Worksheet
Dim SuBe As Range
Dim s As String, fiAd As String
Dim i As Long, Zähler As Long, laR As Long
Application.ScreenUpdating = False
Set Blatt1 = ThisWorkbook.Sheets("CAQ")
Set Blatt2 = ThisWorkbook.Sheets("Endkontrolle")
Set Blatt3 = ThisWorkbook.Sheets("Tank")
Set Blatt4 = ThisWorkbook.Sheets("Schweissen")
endz = 1
tankz = 1
schwz = 1
laR = Blatt1.Cells(Rows.Count, 5).End(xlUp).Row
With Blatt1.Range("E1:E" & laR)
s = "Endkontrolle"
Set SuBe = .Find(What:=s, After:=Range("E" & laR), LookAt:=xlWhole)
If Not SuBe Is Nothing Then
fiAd = SuBe.Address
endz = endz + 1
Blatt2.Range("A" & endz & ":IV" & endz).Value = _
Blatt1.Range("A" & SuBe.Row & ":IV" & SuBe.Row).Value
Do
Set SuBe = .FindNext(SuBe)
If Not SuBe Is Nothing Then
If SuBe.Address <> fiAd Then
endz = endz + 1
Blatt2.Range("A" & endz & ":IV" & endz).Value = _
Blatt1.Range("A" & SuBe.Row & ":IV" & SuBe.Row).Value
End If
End If
Loop While Not SuBe Is Nothing And SuBe.Address <> fiAd
End If
s = "Tank"
Set SuBe = .Find(What:=s, After:=Range("E" & laR), LookAt:=xlWhole)
If Not SuBe Is Nothing Then
fiAd = SuBe.Address
tankz = tankz + 1
Blatt3.Range("A" & tankz & ":IV" & tankz).Value = _
Blatt1.Range("A" & SuBe.Row & ":IV" & SuBe.Row).Value
Do
Set SuBe = .FindNext(SuBe)
If Not SuBe Is Nothing Then
If SuBe.Address <> fiAd Then
tankz = tankz + 1
Blatt3.Range("A" & tankz & ":IV" & tankz).Value = _
Blatt1.Range("A" & SuBe.Row & ":IV" & SuBe.Row).Value
End If
End If
Loop While Not SuBe Is Nothing And SuBe.Address <> fiAd
End If
s = "Schweissung"
Set SuBe = .Find(What:=s, After:=Range("E" & laR), LookAt:=xlWhole)
If Not SuBe Is Nothing Then
fiAd = SuBe.Address
schwz = schwz + 1
Blatt4.Range("A" & schwz & ":IV" & schwz).Value = _
Blatt1.Range("A" & SuBe.Row & ":IV" & SuBe.Row).Value
Do
Set SuBe = .FindNext(SuBe)
If Not SuBe Is Nothing Then
If SuBe.Address <> fiAd Then
schwz = schwz + 1
Blatt4.Range("A" & schwz & ":IV" & schwz).Value = _
Blatt1.Range("A" & SuBe.Row & ":IV" & SuBe.Row).Value
End If
End If
Loop While Not SuBe Is Nothing And SuBe.Address <> fiAd
End If
End With
Application.ScreenUpdating = True
End Sub

Viel Erfolg wünscht
WernerB.
P.S.: Dieses Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter !

AW: Makro optimieren

Heino

Hallo Werner
Ich Danke Dir
Die Arbeitsmappe ist jetzt schneller
Gruß Heino

Beliebteste Forumthreads (12 Monate)

Forumthread: Makro optimieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread