Paste funktioniert manchmal nicht
06.06.2019 15:04:56
Arnd-Olav
ich arbeite mit SAP und Excel.
Für einige Aufgaben kopiere ich aus SAP die Ansicht mit CTRL Y ins Clipboard und füge sie per Button (welches VBA startet) in ein Sheet.
Nun funktioniert seit einuiger Zeit dieses Einfügen nur noch jedes zweite Mal.
Probiere ich das Copy and Paste mit WORD anstatt Excel so funktioniert es immer anstandslos.
Der Code stoppt immer hier in der vorletzten Zeile beim Einfügen:
Sub basismacro()
'Application.Calculation = xlCalculationManual 'Turn off automatic sheet calculations
Application.ScreenUpdating = False 'Turns off screnn updating
Application.DisplayStatusBar = False 'Turns off the status bar
ActiveSheet.DisplayPageBreaks = False 'Turns off
Dim VAR_ARRAY_AQPL As Variant
Dim LNG_LAST_ROW_AQPL_RESULTS As Long
Dim LNG_LAST_ROW_AQPL_LIST As Long
Dim LNG_LRAQPL As Long
Dim VAR_ARRAY_ZPOM As Variant
Dim LNG_LAST_ROW_ZPOM_PN As Long
Dim LNG_LAST_ROW_ZPOM_LIST As Long
Dim LNG_LRZPOM As Long
Dim VAR_ARRAY_DISTRIBUTE As Variant
Dim LNG_LAST_ROW_DISTRIBUTE_PN As Long
Dim LNG_LAST_ROW_DISTRIBUTE_LIST As Long
Dim LNG_LRDISTRIBUTE As Long
Dim VAR_ARRAY_ZFAM As Variant
Dim LNG_LAST_ROW_ZFAM_PN As Long
Dim LNG_LAST_ROW_ZFAM_LIST As Long
Dim LNG_LRDZFAM_PN As Long
Dim myArray
Dim LNG_LAST_ROW_ZFAM_RESULT As Long
Dim LNG_LRDZFAM_RESULT As Long
Dim LNG_COUNT_ZFAM As Long
'Range("C43").Select
' ActiveCell.FormulaR1C1 = "0"
With Worksheets("ZCOR_INPUT") '##### ZCOR Input #####
.Range("A:A").ClearContents 'Clear range for macro input
.Range("A1").PasteSpecial 'Macro input from ZCOR
End With
Ich habe den Eindruck, das Problem entsteht in einem zweiten Makro, welches ich manchmal im Anschluß an das Einfügen verwende, um eine Email an verschiedene Supplier zu senden.Der Code für das Versenden ist der folgende:
Sub Mail_to_combo_display()
Dim s As Integer
Dim t As Integer
Dim r As Integer
Dim rr As Integer
Dim we As Integer
Dim supps As Integer
Dim nam(100) As String
Dim MyCell As Range
Dim MyContacts As Range
Dim rng As Range
Dim rnginfo As Range
Dim criteriarange As Range
Dim criteriacell As Range
Dim OutApp As Object
Dim OutMail As Object
Dim oaccount As Object
Dim strfrom As String
Dim strcc As String
Dim strsl As String
Dim strbody As String
Dim strbody1 As String
Dim strbody2 As String
Dim strbody3 As String
Dim strbody4 As String
Dim strbody5 As String
Dim SigString As String
Dim Signature As String
Dim filepath As String
If Worksheets("UI").Range("O2").Value Like "*Electrical*" Then
Worksheets("MAIL_DEFAULTS").Range("f22:f27").Copy Destination:=Sheets("mailing").Range("A55: _
A60")
Else
Worksheets("MAIL_DEFAULTS").Range("e22:e27").Copy Destination:=Sheets("mailing").Range("A55: _
A60")
End If
'Prepare input for mail on sheet MAIL_DEFAULTS
With Worksheets("MAIL_DEFAULTS").Select
Range("e10:e20").Select '--- *** TO BE ADJUSTED *** ---
Selection.Copy
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:= _
False
End With
filepath = Sheets("UI").Range("B43")
Sheets("UI").Range("c43").Value = 0
strbody1 = Sheets("MAIL_DEFAULTS").Range("c10")
strbody2 = Sheets("MAIL_DEFAULTS").Range("c12")
strbody3 = Sheets("MAIL_DEFAULTS").Range("c13")
strbody4 = Sheets("MAIL_DEFAULTS").Range("c14")
strbody5 = Sheets("MAIL_DEFAULTS").Range("c15")
strfrom = "procurement.aog@meier.com"
strsl = Sheets("MAIL_DEFAULTS").Range("c11")
With Worksheets("mailing").Select
Range("A55:A60").Select
Selection.ClearContents
Range("A55:A60").Select
Sheets("mailing").Select
Range("C2:C30").Select
Selection.ClearContents
Range("C2:C30").Select
End With
Worksheets("MAIL_DEFAULTS").Range("e22:e27").Copy Destination:=Sheets("mailing").Range("A55:A60" _
)
With Worksheets("mailing")
For s = 2 To Range("A66").End(xlUp).Row ' Schleifenstart, gehe von Zeile 2 bis letzte Zeile
we = 0 ' Temporäre Variable auf null setzen
For t = 2 To s ' Schleifenstart, gehe von Zeile 2 bis aktuelle Zelle
If nam(t) = Cells(s, 1) Then
we = 1 ' Wenn Wert aus Variable gleich aktuelle Zelle dann temporäre Variable _
gleich 1
Next t ' Wendepunkt für Schleife
If we = 0 Then
nam(t) = Cells(s, 1) ' Wenn temp. Variable gleich null dann Wert aus aktueller Zelle _
in Variable
Next s ' Wendepunkt für Schleife
' Werte in neuer Spalte ausgeben
For r = 1 To t ' Schleifenstart
If nam(r) "" Then ' Wenn Variable einen Inhalt hat, dann ...
rr = rr + 1 ' ... Zähler für Zelle im Ausgabebereich plus 1
Cells(rr, 3) = nam(r) ' ... Variable in Zelle schreiben
End If ' Ende der Bedingung
Next r ' Wendepunkt für Schleife
'Set the range to evaluate to rng.
Set rng = Range("c1:c10")
'Loop backwards through the rows
'in the range that you want to evaluate.
For i = rng.Rows.Count To 1 Step -1
'If cell i in the range contains an "x", delete the entire row.
If rng.Cells(i).Value = "x" Then rng.Cells(i).EntireRow.Delete
Next
End With
With Worksheets("mailing")
Set criteriarange = Range("C1:C30")
For Each criteriacell In criteriarange
If criteriacell.Value Like "* investigate *" Then
criteriacell.ClearContents
End If
Next criteriacell
End With
'ActiveWorkbook.Application.Calculate
'With Worksheets("MAIL_DEFAULTS")
Set MyContacts = Sheets("mailing").Range("C1:C30")
''supps = WorksheetFunction.CountIf(.Range("c1:c30"), "=*@*")
'End With
'MsgBox (supps)
'Sheets("MAIL_DEFAULTS").Range("J1").Value = supps
With Worksheets("MAIL_DEFAULTS").Select
Range("e20").Select '--- *** TO BE ADJUSTED *** ---
Selection.Copy
Range("C20").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:= _
False
End With
'--- *** TO BE ADJUSTED *** ---
Set rnginfo = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rnginfo = Worksheets("INFO_VALIDATION").Range("J50:K54").SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rnginfo = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rnginfo Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & vbNewLine & "please correct _
and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With '------
'Schritt 2: Tabellenblatt kopieren, in neue Arbeitsmappe einfügen und speichern
Sheets("quote_form").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\quote_form.xlsx"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & "\Microsoft\Signatures\aog.htm"
If Dir(SigString) "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "procurement.aog@airbus.com"
.BCC = ""
For Each MyCell In MyContacts
.BCC = .BCC & Chr(59) & MyCell.Value
Next MyCell
.Subject = strsl
.HTMLBody = "
" & strbody1 & "
" & strbody2 & "
" & RangetoHTMLia(rnginfo) & "
_
" & strbody4 & "
" & strbody3 & "
" & strbody5 & "
" & Signature '--- *** TO BE ADJUSTED *** ---
.Attachments.Add (ThisWorkbook.Path & "\quote_form.xlsx")
.Display
End With
'Schritt 5: Temporäre Excel-Datei löschen
ActiveWorkbook.Close SaveChanges:=True
Kill ThisWorkbook.Path & "\quote_form.xlsx"
Sheets("UI").Select
Range("a1").Select
AppActivate Application.Caption
UserForm1.Show
If Sheets("UI").Range("c43").Value = 1 Then
Exit Sub
End If
emailname = Sheets("MAIL_DEFAULTS").Range("b20")
myID = OutMail.ConversationIndex
With OutMail
.Send
End With
Do
Application.Wait (Now + TimeValue("00:00:01"))
DoEvents
found = False
For Each OutMail In OutApp.Session.GetDefaultFolder(5).Items '"Gesendete Objekte"
If OutMail.ConversationIndex = myID Then 'sucht die Email über die _
ID
OutMail.SaveAs filepath & emailname & ".msg"
found = True
End If
Next
Loop Until found
With Worksheets("MAIL_DEFAULTS")
Range("b21").Copy
End With
Sheets("UI").Select
Range("a1").Select
Set OutApp = Nothing
Set OutMail = Nothing
Application.EnableEvents = True
End Sub
Function RangetoHTMLia(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTMLia
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTMLia = ts.readall
ts.Close
RangetoHTMLia = Replace(RangetoHTMLia, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close SaveChanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Hat jemand eine Idee, woran das liegt, das Excel das Clipboard nur sporadische infügen will?