Moinsen,
also Tabellenblatt1 ist die Eingabetabelle, hier werden Daten eingegeben. Mit einem Makro werden diese Daten dann aufbereitet in einer Tabelle für das Erstellen von Serienbriefen (dabei werden mehrfachnennungen ausgesiebt) --> Tabelleblatt 3, eine zweite Liste zum Versandt --> Tabellenblatt 4, am Schluss wird die Datei dann mit Datum und Co. gespeichert. anbei mal der VBA Text.
Nun möchte ich vor dem Speichern, das im Tabellenblatt1 (Eingabeliste) die Zeilen (in der Spalte A) nummeriert werden, wenn Spalte D ausgefüllt ist.
Ich hoffe das es jetzt verständlicher ist.
LG
Chris
Public MYPATH As String
Option Explicit
Sub Start()
'Kopieren der Daten für die umschläge
'Namen
Worksheets("Auswahllisten").Range("F2:F105").Copy
Worksheets("Daten Umschläge").Range("A2").PasteSpecial xlPasteValues
'Adresse
Worksheets("Eingabetabelle").Range("H3:H105").Copy
Worksheets("Daten Umschläge").Range("B2").PasteSpecial xlPasteValues
'PLZ Ort
Worksheets("Eingabetabelle").Range("I3:I105").Copy
Worksheets("Daten Umschläge").Range("C2").PasteSpecial xlPasteValues
'Kopieren der Daten für LLBB
'WUS
Worksheets("Eingabetabelle").Range("D3:D105").Copy
Worksheets("Daten LLBB").Range("A2").PasteSpecial xlPasteValues
'Anzahl Proben
Worksheets("Eingabetabelle").Range("E3:E105").Copy
Worksheets("Daten LLBB").Range("B2").PasteSpecial xlPasteValues
'Name TA
Worksheets("Eingabetabelle").Range("F3:F105").Copy
Worksheets("Daten LLBB").Range("C2").PasteSpecial xlPasteValues
'Name Jäger
Worksheets("Eingabetabelle").Range("G3:G105").Copy
Worksheets("Daten LLBB").Range("D2").PasteSpecial xlPasteValues
'Telefon
Worksheets("Eingabetabelle").Range("J3:J105").Copy
Worksheets("Daten LLBB").Range("E2").PasteSpecial xlPasteValues
'Anmerkung
Worksheets("Eingabetabelle").Range("L3:L105").Copy
Worksheets("Daten LLBB").Range("F2").PasteSpecial xlPasteValues
'Duplikate entfernen
Worksheets("Daten Umschläge").Range("$A$1:$C$105").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
'Numnmerierung einfügen
Range("a3:a105").FormulaLocal = "=WENN(NICHT(ISTLEER(B3));ANZAHL2($B$3:B3);"")"
'Datei Speichern und beenden
'Worksheets("Eingabetabelle").SaveCopyAs "DATEIPFAD_" & Format(Now, "dd.mm.yyyy") & ".xlsm"
'ThisWorkbook.Saved = True
'Application.Quit
Call MacroMitDeinemFormularSteuerelementVerknuepfen
End Sub
'Option Explicit
Sub MacroMitDeinemFormularSteuerelementVerknuepfen()
Dim sText As String
MYPATH = Environ("temp")
sText = "Sehr geehrte Damen und Herren,<br><br>"
sText = sText & "anbei die Daten der heutigen XXX."
sText = sText & ""
Call SendSheetOutlook( _
"XXX", _
"XXX", _
"", _
sText)
End Sub
Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, ByVal sText As String)
Dim olApp As Object
Dim AWS As String
Dim olOldBody As String
'define temporary Path and Filename
AWS = MYPATH & "\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "_" & _
WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "")
'export File as PDF
AWS = AWS 'debug-stop
Worksheets("Daten LLBB").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
AWS = AWS & ".pdf"
'Make Email
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .htmlBody
.To = sTo
.cc = sCC
.Subject = sSubject
.htmlBody = sText & olOldBody
.Attachments.Add AWS
End With
AWS = AWS 'debug-stop
'remove TEMP file
'********************************
'wenn du das PDF behalten möchtest, diese Zeile auskommentieren!
'sonst wird das temporäre PDF wieder gelöscht
'Kill AWS
'********************************
'Datei Speichern und beenden
ActiveWorkbook.SaveCopyAs "DATEIPFAD" & Format(Now, "dd.mm.yyyy") & ".xlsm"
ThisWorkbook.Saved = True
Application.Quit
End Sub
'Gleiche Fehlermeldung wieder.
|