AW: Macrostart nach Einfügen von Werten
Werten
Hi,
danke für die schnellen Antworten. Prinzipiell funktioniert das Aufrufen des Makros auch. Aber nun spinnt mein Macro, es schafft und schafft und findet kein Ende und ich weiß nicht warum. Beim manuellen Aufruf funktioniert es.
Die Daten sollen reihenweise in ein anderes Tabellenblatt einsortiert werden und anschließend ausgedruckt. Dann kommt die nächste Reihe dran....einsortieren...ausdrucken usw. bis keine Daten mehr vorhanden sind.
Hier ist mein Macro. Vielleicht erkennt ihr ja, was da faul ist.
Sub Formulare()
'Formular ausfüllen und drucken
letzteZeile = Cells.SpecialCells(xlCellTypeLastCell).Row
For z = letzteZeile To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(z)) = 0 Then Rows(z).Delete
Next
Merker = 1
Do
Merker = Merker + 1
If Worksheets("Labbaseliste").Cells(Merker, 1).Value = "" Then
MsgBox ("Keine einzutragenden Daten mehr vorhanden!")
Cells.Select 'Labbasedaten löschen
Selection.ClearContents
Exit Sub
Else
Worksheets("Probenbeschreibung").Range("I1").Value = Worksheets("Labbaseliste").Cells(Merker, 1).Value
Worksheets("Probenbeschreibung").Range("C7").Value = Worksheets("Labbaseliste").Cells(Merker, 2).Value
Worksheets("Probenbeschreibung").Range("C12").Value = Worksheets("Labbaseliste").Cells(Merker, 6).Value
Worksheets("Probenbeschreibung").Range("D17").Value = Worksheets("Labbaseliste").Cells(Merker, 3).Value
If Worksheets("Labbaseliste").Cells(Merker, 5).Value = "Rotwein" Then
Worksheets("Probenbeschreibung").Range("E9").Value = "X"
ElseIf Worksheets("Labbaseliste").Cells(Merker, 5).Value = "Weißwein" Then
Worksheets("Probenbeschreibung").Range("H9").Value = "X"
ElseIf Worksheets("Labbaseliste").Cells(Merker, 5).Value = "" Then
Worksheets("Probenbeschreibung").Range("H9").Value = ""
End If
If Worksheets("Labbaseliste").Cells(Merker, 4).Value = "0,50 l" Then
Worksheets("Probenbeschreibung").Range("B26").Value = "X"
ElseIf Worksheets("Labbaseliste").Cells(Merker, 4).Value = "0,75 l" Then
Worksheets("Probenbeschreibung").Range("B27").Value = "X"
ElseIf Worksheets("Labbaseliste").Cells(Merker, 4).Value = "1,00 l" Then
Worksheets("Probenbeschreibung").Range("B28").Value = "X"
ElseIf Worksheets("Labbaseliste").Cells(Merker, 4).Value = "1,5 l" Then
Worksheets("Probenbeschreibung").Range("B29").Value = "X"
ElseIf Worksheets("Labbaseliste").Cells(Merker, 4).Value = "" Then
Worksheets("Probenbeschreibung").Range("B27").Value = ""
End If
Drucken
löschen
End If
Loop
End Sub
Sub Drucken() ' Drucken eines Formular
Worksheets("Probenbeschreibung").PrintOut Copies:=1, Collate:=True
End Sub
Sub löschen() 'Formularwerte löschen
Worksheets("Probenbeschreibung").Range("I1,C7,C12:D12,D17,E9,H9,B26,B27,B28,B29").ClearContents
End Sub
Danke
Liebe Grüße
Sigi
Private Sub Worksheet_Change(ByVal Target As Range)
On Error goto Reset
Application.enableEvents = false
Call Dein_Makro
Reset:
Application.enableEvents = True
End Sub
Bert
daaaanke Bert.... es klappt... auch wenn ichs nicht ganz verstehe....seufz