Laufzeit 1004 WS.copy

Hallo Zusammen,
ich habe ein Makro zusammengebaut welches eine Datei öffnet und die einzelnen Tabellenblätter im gleichen Pfad als einzelne Dateien abspeichert.
Diese Dateien werden anschließend mit Betreff und Text in eine E-Mail gepackt und werden verschickt.
Dies funktioniert allerdings nur mit von mir erstellten Basisdateien im .xlsx oder .xlsm Format.
Leider handelt es sich bei der Basisdatei um eine .xls 97-03.
Meine Idee war es zuerst die Basisdatei zu öffnen, als xlsm oder xlsx abzulegen um diese _ anschließend wieder zu öffnen um das Makro ausführen zu können. Dies funktioniert leider auch nicht ... auf keine Weise lässt sich die Basis verarbeiten.


Sub GesundheitsgesprächeImportundEmail()
Dim Datei As String
Dim Datei2 As String
Dim oWs As Worksheet
Dim outObj As Object
Dim Mail As Object
Dim Pfad As String
On Error GoTo Fehler
Datei = Application.GetOpenFilename("alle Excel-Dateien(*),*xls")
If Datei = "Falsch" Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
MsgBox "Ausgewählte Datei: " & Datei, , ""
Application.DisplayAlerts = False
Workbooks.Open Filename:=Datei, Local:=True
'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveWorkbook.Name & ".xlsx",  _
FileFormat:=xlOpenXMLWorkbookApplication 'xlOpenXMLWorkbookMacroEnabled
'ActiveWorkbook.Close
'On Error GoTo Fehler
'Datei2 = Application.GetOpenFilename("alle Excel-Dateien(*),*xls")
'If Datei2 = "Falsch" Then
' MsgBox "keine Datei ausgewählt", , "Abbruch"
'  Exit Sub
'End If
'Workbooks.Open Filename:=Datei2, Local:=True
Call Blätter_einzeln_speichern
Pfad = ThisWorkbook.Worksheets(1).Cells(39, 4).Value
Dateiname1 = ThisWorkbook.Worksheets(1).Range("F8")
Application.DisplayAlerts = True
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
With Mail
.Subject = "XXX"
.Body = "XXX"
.To = ThisWorkbook.Worksheets("A").Range("D8")
.Attachments.Add Pfad1
.send
End With
'Mail.Display
Set Mail = Nothing
Set outObj = Nothing
Exit Sub
Fehler:
Set Quelle = Nothing
Set Ziel = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Sub Blätter_einzeln_speichern()
Dim ws As Worksheet
For Each ws In Sheets
ws.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close True
Next ws
End Sub

Gibt es überhaupt eine Möglichkeit auf Grundlage der alten Excel Datei?
Ich habe keine Chance diese neu aufzusetzen oder Ähnliches, da es sich um exteren Informationen handelt.
Ich hoffe ihr könnt mir weiterhelfen und danke vielmals im voraus!
LG
Robert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub CopySheets() Dim lngCounter As Long Dim wbOrig As Workbook Dim wbTarg As Workbook Dim Datei As String Dim Anzahl As Integer Call Test On Error GoTo Fehler Datei = Application.GetOpenFilename("alle Excel-Dateien(*),*xls") If Datei = "Falsch" Then MsgBox "keine Datei ausgewählt", , "Abbruch" Exit Sub End If MsgBox "Ausgewählte Datei: " & Datei, , "" Application.DisplayAlerts = False Workbooks.Open Filename:=Datei, Local:=True Set wbOrig = Workbooks(Datei) Set wbTarg = Workbooks("Zwischenspeicher.xls") Anzahl = wbOrig.Sheets.Count For lngCounter = 1 To Anzahl wbOrig.Sheets(lngCounter).Copy After:=wbTarg.Sheets(lngCounter) Next lngCounter Set wbTarg = Nothing Set wbOrig = Nothing Fehler: MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _ & "Beschreibung: " & Err.Description _ , vbCritical, "Fehler" End Sub Sub Test() Dim wkbMappe As Workbook Set wkbMappe = Workbooks.Add wkbMappe.SaveAs "C:\Temp\Zwischenspeicher.xls" MsgBox wkbMappe.Name & " " & wkbMappe.FullName 'wkbMappe.Close False End Sub

Hi
wenn ein Fehler auftritt, solltest du als erstes deine Fehlerbehandlungsroutine deaktivieren (dh das On Error Goto Fehler auskommentieren und ein Hochkomma davorsetzen)
das hat dann den Effekt, dass das Makro direkt bei der Fehlerverursachenden Zeile anhält, dir diese Zeile anzeigt und du beispielswiese die Variablenwert und betroffenen Zellen direkt überprüfen kannst.
Das sind wichtige Informationen die du für eine schnelle Ursachenfindung brauchst, die aber durch eine Fehlerbehandlungsroutine vernichtet werden.
die Fehlerbehandlungsroutine sollte man erst einbauen, wenn die Testphase abgeschlossen ist (bis auf den Test der Fehlerbehandlungsroutine) und fehlerfrei läuft.
In Makros, die ich für meinen "Eigenbedarf" erstelle, baue ich sowas erst gar nicht ein.
Gruß Daniel

Pfad = ThisWorkbook.Worksheets(1).Cells(39, 4).Value Dateiname1 = ThisWorkbook.Worksheets(1).Range("F8") Application.DisplayAlerts = True Set outObj = CreateObject("Outlook.Application") Set Mail = outObj.CreateItem(0) With Mail .Subject = "XXX" .Body = "XXX" .To = ThisWorkbook.Worksheets("A").Range("D8") .Attachments.Add Pfad1 .send End With 'Mail.Display Set Mail = Nothing Set outObj = Nothing

Option Explicit Sub GesundheitsgesprächeImportundEmail() Dim Datei As String Dim wkb As Workbook Dim objOL As Object, objMail As Object Dim i As Integer Dim strAtt As String Dim arrAtt 'On Error GoTo Fehler Datei = Application.GetOpenFilename("alle Excel-Dateien(*),*xls") If Datei = "Falsch" Then MsgBox "keine Datei ausgewählt", , "Abbruch" Exit Sub End If 'MsgBox "Ausgewählte Datei: " & Datei, , "" Application.DisplayAlerts = False Set wkb = Workbooks.Open(Filename:=Datei, Local:=True) Call Blätter_einzeln_speichern(ActiveWorkbook, strAtt) wkb.Close False Application.DisplayAlerts = True arrAtt = Split(strAtt, ";") Set objOL = CreateObject("Outlook.Application") Set objMail = objOL.CreateItem(0) With objMail .Subject = "XXX" .Body = "XXX" .To = ThisWorkbook.Worksheets("A").Range("D8") For i = 0 To UBound(arrAtt) .Attachments.Add arrAtt(i) Next ' .send .display End With Set objMail = Nothing Set objOL = Nothing Exit Sub Fehler: MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _ & "Beschreibung: " & Err.Description _ , vbCritical, "Fehler" End Sub Sub Blätter_einzeln_speichern(wkb As Workbook, strAtt As String) Dim ws As Worksheet, strName As String For Each ws In wkb.Worksheets strName = ThisWorkbook.Path & "\" & ws.Name & ".xls" ws.Copy ActiveWorkbook.SaveAs Filename:=strName strAtt = strAtt & ";" & strName ActiveWorkbook.Close True Next ws strAtt = Mid(strAtt, 2) End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread