Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1752to1756
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Code

VBA Code
29.04.2020 15:05:39
Chris
Hallo zusammen,
ich stehe gerade auf dem Schlauch mit dem zusammenfügen zweier VBA Codes, die jeweils mit einem Formularsteuerelement (Button) gestartet. Nun möchte ich den Code von nur einem Button aus starten lassen. Ich habe mit meinen bescheidenen Fähigkeiten bereits alles versucht, bekomme jedoch ständig Fehlermeldungen (Fehler beim Kompilieren, als Beispiel).
Kann mir jemand weiterhelfen bevor ich ganz verzweifel?
1.
Private Sub CommandButton1_Click()
'Kopieren der Daten für die Umschläge
Worksheets("Auswahllisten").Range("G2:G105").Copy
Worksheets("Daten Umschläge").Range("A2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("H2:H105").Copy
Worksheets("Daten Umschläge").Range("B2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("I2:I105").Copy
Worksheets("Daten Umschläge").Range("C2").PasteSpecial xlPasteValues
'Kopieren der Daten für BB
Worksheets("Auswahllisten").Range("G2:G105").Copy
Worksheets("Daten BB").Range("A2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("D2:D105").Copy
Worksheets("Daten BB").Range("B2").PasteSpecial xlPasteValues
Worksheets("Auswahllisten").Range("H2:H105").Copy
Worksheets("Daten BB").Range("C2").PasteSpecial xlPasteValues
'Duplikate entfernen
Worksheets("Daten Umschläge").Range("$A$1:$G$105").RemoveDuplicates Columns:=1, Header:= _
xlYes
2.
Option Explicit
Private MYPATH As String
Sub MacroMitDeinemFormularSteuerelementVerknuepfen()
Dim sText As String
MYPATH = Environ("temp")
sText = "
Sehr geehrte Damen und Herren,
sText = sText & "

anbei die Daten .

" sText = sText & "
""
" Call SendSheetOutlook( _ "Betreffzeile", _ "Mailadresse", _ "", _ 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
Worksheets(4).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
'remove TEMP file
'wenn du das PDF behalten möchtest, diese Zeile auskommentieren!
'sonst wird das temporäre PDF wieder gelöscht
'Kill AWS
3.
'Datei Speichern und beenden
'ActiveWorkbook.SaveCopyAs "C:\Dateipfad\liste_" & Format(Now, "dd.mm.yyyy") & ".xlsm"
'ThisWorkbook.Saved = True
'Application.Quit
End Sub
Die Nummerierung soll die Neuordnung darstellen und ist natürlich nicht im Originalcode vorhanden.
verzweifelten Dank schon mal vorab.

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Code
29.04.2020 15:15:06
ChrisL
Hi
Das erste Makro umbenennen und beide Makros in ein allgemeines Standardmodul kopieren.
Sub MeinMakro()
End Sub

Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, ByVal sText As   _
_
String)
End Sub
------------------------------------------------------------
Das Makro kannst du dann wie folgt aus dem Modul der Tabelle/Userform starten:
Private Sub CommandButton1_Click()
Call MeinMakro
End Sub
Sieht mir übrigens nach Active-X Button und nicht Formularsteuerelement aus.
cu
Chris
Anzeige
AW: VBA Code
29.04.2020 15:40:04
Chris
Danke schon mal dafür, nur bin ich entwedern schon zu "durch" um das noch zu checken oder doch nur zu lange an dem Code, das ich blind geworden bin.
Jetzt sagt er mir: fehler beim kompilieren mehrdeutiger name: sendsheetoutlook
in der Zeile:
Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, ByVal sText As String)
AW: VBA Code
29.04.2020 16:02:14
ChrisL
Mit "kopieren" meinte ich natürlich "verschieben" d.h. die gleiche Prozedur darf nicht zweimal vorhanden sein.
AW: VBA Code
29.04.2020 16:11:27
Chris
Ja, den fehler habe ich schon ausgeräumt. Nun bekomme ich in der Zeile:
Worksheets(4).ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
den Fehler: Laufzeitfehler '1004' das Dokument wurde nicht gespeichert. Das Dokument ist möglicherweise geöffnet, oder beim Speichern ist ein Fehler aufgetreten. Die beiden Codes haben zuvor ja auch funktioniert.
Anzeige
AW: VBA Code
29.04.2020 16:48:53
ChrisL
Wird bald mal Zeit, dass du eine Beispieldatei hoch lädst.
Mach mal aus
Private MYPATH As String
Public MYPATH As String
Die Zeile ebenfalls ins Standardmodul, ganz an den Anfang, ausserhalb von Sub.
cu
Chris
AW: VBA Code
29.04.2020 17:14:39
Chris
Nope, leider nicht. Ich fress den gleich.... Sorry, kleiner Anfall von Emotion. Im Moment sieht das bei mir so aus:
Sub Start()
'Kopieren der Daten für die umschläge
Worksheets("Auswahllisten").Range("G2:G105").Copy
Worksheets("Daten Umschläge").Range("A2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("H2:H105").Copy
Worksheets("Daten Umschläge").Range("B2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("I2:I105").Copy
Worksheets("Daten Umschläge").Range("C2").PasteSpecial xlPasteValues
'Kopieren der Daten für LLBB
Worksheets("Auswahllisten").Range("G2:G105").Copy
Worksheets("Daten LLBB").Range("A2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("D2:D105").Copy
Worksheets("Daten LLBB").Range("B2").PasteSpecial xlPasteValues
Worksheets("Auswahllisten").Range("H2:H105").Copy
Worksheets("Daten LLBB").Range("C2").PasteSpecial xlPasteValues
'Duplikate entfernen
Worksheets("Daten Umschläge").Range("$A$1:$G$105").RemoveDuplicates Columns:=1, Header:= _
xlYes
'Datei Speichern und beenden
'ActiveWorkbook.SaveCopyAs "N:\VL_Veterinaeramt\GLAMANN\TESTliste_" & Format(Now, "dd.mm. _
yyyy") & ".xlsm"
'ThisWorkbook.Saved = True
'Application.Quit
End Sub
'Option Explicit
Public MYPATH As String
Sub MacroMitDeinemFormularSteuerelementVerknuepfen()
Dim sText As String
MYPATH = Environ("temp")
sText = "
Sehr geehrte Damen und Herren, sText = sText & "

anbei die Daten der heutigen Trichinproben aus Oranienburg.

" sText = sText & " ""
" Call SendSheetOutlook( _ "Trichinendaten Oranienburg", _ "Veterinaeramt@oberhavel.de", _ "", _ 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 Worksheets(4).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 '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 "N:\VL_Veterinaeramt\GLAMANN\TESTliste_" & Format(Now, "dd.mm. _ yyyy") & ".xlsm" 'ThisWorkbook.Saved = True 'Application.Quit End Sub

Gleiche Fehlermeldung wieder.
Anzeige
AW: VBA Code
29.04.2020 17:18:43
Chris
Nope, leider nicht. Ich fress den gleich.... Sorry, kleiner Anfall von Emotion. Im Moment sieht das bei mir so aus:
Sub Start()
'Kopieren der Daten für die umschläge
Worksheets("Auswahllisten").Range("G2:G105").Copy
Worksheets("Daten Umschläge").Range("A2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("H2:H105").Copy
Worksheets("Daten Umschläge").Range("B2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("I2:I105").Copy
Worksheets("Daten Umschläge").Range("C2").PasteSpecial xlPasteValues
'Kopieren der Daten für LLBB
Worksheets("Auswahllisten").Range("G2:G105").Copy
Worksheets("Daten LLBB").Range("A2").PasteSpecial xlPasteValues
Worksheets("Eingabetabelle").Range("D2:D105").Copy
Worksheets("Daten LLBB").Range("B2").PasteSpecial xlPasteValues
Worksheets("Auswahllisten").Range("H2:H105").Copy
Worksheets("Daten LLBB").Range("C2").PasteSpecial xlPasteValues
'Duplikate entfernen
Worksheets("Daten Umschläge").Range("$A$1:$G$105").RemoveDuplicates Columns:=1, Header:= _
xlYes
'Datei Speichern und beenden
'ActiveWorkbook.SaveCopyAs "N:\VL_Veterinaeramt\GLAMANN\TESTliste_" & Format(Now, "dd.mm. _
yyyy") & ".xlsm"
'ThisWorkbook.Saved = True
'Application.Quit
End Sub
'Option Explicit
Public MYPATH As String
Sub MacroMitDeinemFormularSteuerelementVerknuepfen()
Dim sText As String
MYPATH = Environ("temp")
sText = "
Sehr geehrte Damen und Herren, sText = sText & "

anbei die Daten der heutigen Trichinproben aus Oranienburg.

" sText = sText & " ""
" Call SendSheetOutlook( _ "Trichinendaten Oranienburg", _ "Veterinaeramt@oberhavel.de", _ "", _ 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 Worksheets(4).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 '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 "N:\VL_Veterinaeramt\GLAMANN\TESTliste_" & Format(Now, "dd.mm. _ yyyy") & ".xlsm" 'ThisWorkbook.Saved = True 'Application.Quit End Sub

Gleiche Fehlermeldung wieder.
Anzeige
AW: VBA Code
29.04.2020 18:22:40
Firmus
Hi Chris,
wenn das Datenblatt, das du in ein PDF bringen willst, bekommst Du Fehler 1004.
Hier ein getestetes Beispiel.
https://www.herber.de/bbs/user/137126.xlsm
Schnipsel das funktioniert:

Worksheets("Daten LLBB").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:= _
xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Schnipsel das den Fehler 1004 bringt:

Worksheets("Daten LLBB-leer").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:= _
xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Benutze besser Worksheets("Daten LLBB") anstelle von Worksheets(4), denn es ist nicht sicher, dass das immer ws(4) ist.
Lass wissen ob es klappt.
Gruß
Firmus
Anzeige
AW: VBA Code
30.04.2020 10:17:34
Chris
Guten Morgen,
Die selbe Zeile funktioniert jedoch in der Originaldatei, mit der aktuell auch gearbeitet wird. Es hat sich ja nichts weiter geändert.
Danke für den Tip mit den Tabellenblättern, ist bereits umgesetzt.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige