Thema Datum  Von Nutzer Rating
Antwort
Rot Sub Ausführung dauert sehr lange
 17.12.2013 08:59:03 MarkiMark
NotSolved
17.12.2013 19:11:33 H27
NotSolved

Ansicht des Beitrags:
Von:
MarkiMark		 Datum:
17.12.2013 08:59:03		 Views:
1695		 Rating:
     
Antwort:
  Ja
Thema:
Sub Ausführung dauert sehr lange

Hi Ihr,

 

Ich brauch da mal eure Hilfe. Folgender Code funktioniert zwar sehr gut, jedoch dauert es sehr lange, bis alle Schritte durchgeführt werden:

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
Option Explicit
 
Public Sub Ordnen()
 
    Sheets("kleine").Select
    Cells.Select
    Selection.ClearContents
    Sheets("mittlere").Select
    Cells.Select
    Selection.ClearContents
    Sheets("grosse").Select
    Cells.Select
    Selection.ClearContents
 
Dim i As Integer
Dim Zelle As Range
Dim leereZeile
Dim j As Long
 
For Each Zelle In Tabelle1.Range("B:B")
 
With Worksheets("kleine")
    j = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    If Not (j = 1 And .Cells(1, 1) = "") Then j = j + 1
End With
i = 1
'For Each Zelle In Tabelle1.Range("B:B")
    If Not Zelle Is Nothing Then
        If Zelle.Value = "<1" & ChrW(956) & "m" Then
            Zelle.EntireRow.Copy
            Worksheets("kleine").Cells(j, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = j + 1
            i = i + 1
    End If
End If
 
 
With Worksheets("mittlere")
    j = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    If Not (j = 1 And .Cells(1, 1) = "") Then j = j + 1
End With
i = 1
    If Not Zelle Is Nothing Then
        If Zelle.Value = "1" & ChrW(956) & "m - 10" & ChrW(956) & "m" Then
            Zelle.EntireRow.Copy
            Worksheets("mittlere").Cells(j, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = j + 1
            i = i + 1
    End If
End If
 
With Worksheets("grosse")
    j = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    If Not (j = 1 And .Cells(1, 1) = "") Then j = j + 1
End With
i = 1
    If Not Zelle Is Nothing Then
        If Zelle.Value = ">10" & ChrW(956) & "m" Then
            Zelle.EntireRow.Copy
            Worksheets("grosse").Cells(j, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = j + 1
            i = i + 1
    End If
End If
 
 
Next Zelle
     
    Sheets("kleine").Select
    Columns("D:E").Select
    Selection.Cut
    Columns("O:O").Select
    ActiveSheet.Paste
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
     
    Sheets("mittlere").Select
    Columns("D:E").Select
    Selection.Cut
    Columns("O:O").Select
    ActiveSheet.Paste
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
     
    Sheets("grosse").Select
    Columns("D:E").Select
    Selection.Cut
    Columns("O:O").Select
    ActiveSheet.Paste
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
     
    Sheets("kleine").Select
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Sheets("mittlere").Select
    Columns("B:B").Select
    Range("B4").Activate
    Selection.Delete Shift:=xlToLeft
    Sheets("grosse").Select
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
     
     
 
End Sub
 
 
 
Hat jemand eine Ahnung woran das liegen und wie man das Problem beheben könnte???
 
Vielen Dank im Voraus.
 
MarkiMark

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Sub Ausführung dauert sehr lange
 17.12.2013 08:59:03 MarkiMark
NotSolved
17.12.2013 19:11:33 H27
NotSolved