Hallo Volti
Dein Code funktioniert wunderbar im Script, das ich gestern gepostet habe. Nun habe ich mir den Tipp eines weiteren Hilfestellers, möglichst keine "select" zu verwenden, zu Herzen genommen und noch weitere Codes optimiert.
Leider bekomme ich nun erneut eine Fehlermeldung bei einer Code-Zeile, welche ich von dir übernommen habe.
Folgende Zeile bereitet Probleme:
WSb.Range("A2").Value = .Range("A2:I" & ZeilMax).Value
hier mein gesamter Code:
Sub Finn_Comfort_bestellen()
'
' Schaltfläche1_Klicken Makro
'
' Bestimmen wieviele Zeilen bestellt werden müssen
Dim ZeileMax As Long
Dim Name As Variant
Dim rngToFill As Range
' Letzte Zeile bestimmen
With ThisWorkbook.Sheets("Finn Comfort")
ZeileMax = .Cells(Rows.Count, 1).End(xlUp).Row
' ZeileMax = .UsedRange.Rows.Count 'die letzte Zeile wird ermittelt
'End With
' Mail inklusive Anhang generieren
Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim SourceWS As Worksheet
Dim WSb As Worksheet
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Copy only selected sheets into new workbook
Set SourceWB = ActiveWorkbook
'Set SourceWS = SourceWB.Worksheets("Finn Comfort")
'SourceWS.Range("A1:I" & ZeileMax).Copy
SourceWB.Windows(1).SelectedSheets.Copy
Set DestinWB = ActiveWorkbook
'Determine Temporary File Path
TempFilePath = Environ$("temp") & "\"
'Determine Default File Name for InputBox
'If SourceWB.Saved Then
'DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
'Else
'DefaultName = SourceWB.Name
DefaultName = "Bestellung"
'End If
'Ask user for a file name
TempFileName = Application.InputBox("Wie söll dä Aahang heissä?", _
"File Name", Type:=2, Default:=DefaultName)
If TempFileName = False Then GoTo ExitSub 'Handle if user cancels
'Determine File Extension
'If SourceWB.Saved = True Then
'FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
'Else
FileExtStr = ".xlsx"
'End If
'Break External Links
ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)
'Loop Through each External Link in ActiveWorkbook and Break it
On Error Resume Next
For x = 1 To UBound(ExternalLinks)
DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
On Error GoTo 0
'Save Temporary Workbook
DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr
'Create Instance of Outlook
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
GoTo ExitSub
End If
On Error GoTo 0
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
On Error Resume Next
With OutlookMessage
.To = ""
.CC = ""
.BCC = ""
.Subject = TempFileName
.Body = "Im Anhang finden Sie die Liste mit unseren Bestellungen" & vbNewLine & vbNewLine & "Orthopädie" & vbNewLine & "Malgaroli & Werne"
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display
End With
On Error GoTo 0
'Close & Delete the temporary file
DestinWB.Close SaveChanges:=False
Kill TempFilePath & TempFileName & FileExtStr
'Clear Memory
Set OutlookMessage = Nothing
Set OutlookApp = Nothing
'Optimize Code
ExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
' Oben Zeile einfügen in "bestellt" - Tab
Set WSb = Sheets("Finn Comfort bestellt")
'Sheets("Finn Comfort bestellt").Select
WSb.Range("A2").EntireRow.Resize(ZeileMax).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
'Rows("2:" & ZeileMax).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
'WSb.Range("A2:K" & ZeileMax).Font.Bold = False
' zu kopierenden Bereich kopieren in "Finn Comfort"-Tab
'Sheets("Finn Comfort").Select
'Range("A2:I" & ZeileMax).Select
'Selection.Copy
'Sheets("Finn Comfort bestellt").Select
'Range("A2:I" & ZeileMax).Select
'ActiveSheet.Paste
'Sheets("Finn Comfort").Select
WSb.Range("A2").Value = .Range("A2:I" & ZeilMax).Value
.Range("A2:I" & ZeileMax).ClearContents
' Kürzel in "bestellt"-Tab einfügen
Name = InputBox("Wer bist du?", "Sali du.")
'Sheets("Finn Comfort bestellt").Select
Set rngToFill = WSb.Range("J2:J" & ZeileMax)
rngToFill.Value = Name
' Aktuelles Datum in Spalte einfügen
Set rngToFill = WSb.Range("K2:K" & ZeileMax)
rngToFill.Value = Date
'gefüllte Zellen auswählen
'Range("A2", Range("d1").End(xlDown).End(xlToRight)).Select
' Knopf nach oben verschieben
'With Worksheets("Finn Comfort")
' With .Shapes("Schaltfläche 1")
' .Top = .TopLeftCell.Offset(-(ZeileMax - 1), 0).Top
'End With
'End With
End With
ActiveWorkbook.Save
End Sub
|