Makro optimieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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 !

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread