Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1696to1700
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

Paste funktioniert manchmal nicht

Paste funktioniert manchmal nicht
06.06.2019 15:04:56
Arnd-Olav
Hallo,
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?

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Paste funktioniert manchmal nicht
06.06.2019 16:37:48
Armin
Hallo Arnd-Olav,
und Du glaubst wirklich, dass das jemand nach baut oder sich das "reinzieht"?
Gruß Armin
AW: Paste funktioniert manchmal nicht
06.06.2019 16:56:47
Arnd-Olav
Mein Gedanke war, dass jemand ähnliche Erfahrung damit gemacht hat, dass die Paste Funktion gelegentlich nicht funktioniert.
Indem ich den ganzen Code poste, mache ich am wenigsten falsch...
AW: Paste funktioniert manchmal nicht
06.06.2019 20:49:46
Luschi
Hallo Armin,
Excel & die Zwischenablage stehen manchmal auf'm Kriegsfuß und das kann man auch testen:
- Zwischenablagefenster in Excel einschalten
- Zellbereich markieren und Strg+C (Kopieren) drücken
- ESC-Taste drücken und damit ist Strg+V (Einfügen) wirkungslos
- in der Zwischenablage ist das Kopierte aber noch sichtbar
- und kann mit der Maus ins Tabellenblatt eingefügt werden
Vielleicht testest Du mal folgenden Link:

https://docs.microsoft.com/de-de/office/vba/access/concepts/windows-api/retrieve-information-from-the-clipboard
Gruß von Luschi
aus klein-Paris
Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige