Makro hängt in einer Schleife
12.09.2005 00:29:58
tat130899
mein Makro hängt kurzzeitig in einer Schleife fest bevor das Makro beendet wird und ist zeitraubend (Ca. 5 sek.). Würde mir bitte jemamd helfen --> hier der Code:
Option Compare Text
Dim bln As Boolean
Private Sub Worksheet_SelectionChange _
(ByVal Target As Excel.Range)
Dim rng As Range
Set rng = Range("B2")
If Target.Address = rng.Address Then bln = True
If bln = True And Target.Address <> rng.Address Then
Call übertragen_aus_Daten
bln = False
End If
End Sub
---------------------------------------------------------
Sub übertragen_aus_Daten()
Dim A, B, C, D, E, F, G, H, I, J, K
Dim zähler
Sheets("Fill In").Select
Range("a1").Select
marke1: For zähler = 1 To 50000
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
End
Else
If ActiveCell.Value = "A" Then
Exit For
Else
End If
End If
Next
ActiveCell.Offset(0, 1).Select
A = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
B = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
C = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
D = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
E = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
F = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
G = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
H = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
I = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
J = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
K = ActiveCell.Value
Sheets("Data").Activate
Sheets("Data").Visible = True
ActiveCell.Activate
'ActiveCell.Offset(1, 0).Select
ActiveCell.Range("b1").Select
marke2: For zähler = 1 To 50000
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Exit For
Else
End If
Next
ActiveCell.Value = A
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = B
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = C
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = D
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = E
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = F
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = G
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = H
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = I
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = J
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = K
ActiveCell.Offset(0, -10).Select
Sheets("Fill In").Select
Range("b2").Select
Sheets("Data").Visible = False
End Sub
Tausend Dank vorab und viele Grüsse
Tobias