arbeite gerade an meinen ersten beiden Makro. Diese laufen auch ich poste sie anschließend. Ich habe jedoch folgendes Problem:
Wenn ich im zweiten Makro die Daten kopiere, wird die gesamte Range übertragen, dass hat zur Folge, dass bei der nächsten Übertragung die letzte Zeile wieder gesucht wird und danach die Daten wieder eingestellt werden! So weit so gut, nur ich fülle ja nie den gesamten Bereich mit Daten, somit entstehen riesige Lücken. Mein eigener Ansatz wäre im ersten Makro nur die Zeilen oder die Zellen zu kopieren die ungleich "" sind und sie in einer Schleife For Zähler to 300 zu kopieren. Diese Befehle kann ich ja auch dann im zweiten Makro verwenden, hiermit erhoffe ich, dass keine Lücken mehr entstehen. Meine Frage, könnt Ihr mir erklären wie eine solche Schleife aussehen muß?
Sub EmailVersand()
Dim rng1 As Range, rng2 As Range, sAdress As String, sMonat As String
Application.ScreenUpdating = False
If MsgBox("Die Daten für die Übertragung werden nachdem Sie auf 'OK' geklickt haben aufbereitet." + Chr(13) + "Dieser Vorgang kann einen Moment dauern, bitte gedulden Sie sich danach " + Chr(13) + "bis das Sendeprotokoll erscheint", 49, "Datenübertragung") <> vbOK Then End
'Hier wird der aktuelle Monat für die Betreffzeile eingestellt
sMonat = Range("M1")
'Hier wird die angegebene emailadresse eingestellt
sAddress = Range("E21").Value
'Hier werden die Werte aus Übergabe Mitarbeiter eingestellt
Set rng1 = Worksheets("Übergabe Mitarbeiter").Range("D6:G300")
'Hier werden die Wert aus Übergabe Kunden eingestellt
Set rng2 = Worksheets("Übergabe Kunden").Range("D6:G300")
'Legt eine neue Arbeitsmappe an und kopiert die Zellen aus rng in diese
Workbooks.Add
rng1.Copy
Range("A1").PasteSpecial (xlPasteValues)
rng2.Copy
Range("E1").PasteSpecial (xlPasteValues)
Columns.AutoFit
ActiveWorkbook.SendMail sAddress, "Monatsdaten für Monat " & sMonat
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
End Sub
Hier ist das zweite Makro, welches diese Arbeitsmappe weiterverarbeitet:
Sub DatenUebertrag()
Dim sFile As String, rng1 As Range, rng2 As Range, Zeilenzahl As Integer
sFile = Range("E19") & (".xls")
If Dir(sFile) = "" Then
MsgBox "Kann eine Datei mit dem angegebenen Pfad: " & Range("E19") & " nicht finden!" _
& vbLf & "Bitte überprüfen Sie den Namen und starten die Übertragung danach erneut."
End
Else
Workbooks.Open Filename:=sFile
End If
Set rng1 = Worksheets("Tabelle1").Range("A1:D300")
Set rng2 = Worksheets("Tabelle1").Range("E1:H300")
Workbooks("test.dat.xls").Activate
Worksheets("Testtabelle1").Activate
'Application.ScreenUpdating = False
Zeilenzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
rng1.Copy
Range("A" & Zeilenzahl + 1).PasteSpecial
'Application.ScreenUpdating = True
End Sub
Ps. Es fällt Euch bestimmt auf, aber rng2 verarbeite ich hier noch nicht weiter, weil ich erstmal das Grundproblem lösen möchte.
Könnt Ihr mir helfen?
Gruß
Wolfgang