Hallo zusammen,
zunächst, danke für eure Zeit und Mühen.
Ich habe ein Problem mit meinem VBA Code, und zwar bekomme ich immer diese Fehlermeldung:
"Die PasteSpecial Methode des Range Objektes konnte nicht ausgeführt werden"
Die Idee des Codes ist die folgende:
Öffne eine PDF Dabei, kopiere den Inhalt der PDF Datei, Füge den Inhalt in das Excel Sheet ein und wähle dann nur spezielle Daten aus und füge diese in andere Excel sheets ein.
Danach wird der Inhalt des Sheets geleert und die Schleife sollte dann die nächste PDF Datei öffnen und wieder das gleiche machen.
-- Der erste Schleifendurchlauf funktioniert hier wunderbar, allerdings beim Öffnen der zweiten PDF erscheint die obige Fehlermeldung. Ich denke es liegt an der Pastespecial Methode im Sendkeys Befehl, allerdings sehe ich den Fehler nicht.
Dim i As Long, j As Integer
Dim zeile As Long
Dim zeilemax As Long
Dim t As Integer
Dim Pfad As String
Dim strPDFFile As String
Dim strFolder As String
For t = 1 To 2
Pfad = ActiveWorkbook.Worksheets("Tabelle2").Range("A" & t).Value
strFolder = "C:\Users\Win7ADM\Desktop\"
strPDFFile = strFolder & Pfad
ActiveWorkbook.FollowHyperlink Address:=strPDFFile, NewWindow:=True
SendKeys "^a", True
SendKeys "^c", True
Range("A60").PasteSpecial
Pfad = ActiveWorkbook.Worksheets("Tabelle2").Range("A" & t).Value
strFolder = "C:\Users\Win7ADM\Desktop\"
strPDFFile = strFolder & Pfad
ActiveWorkbook.FollowHyperlink Address:=strPDFFile, NewWindow:=True
SendKeys "^{DOWN}"
SendKeys "^a", True
SendKeys "^c", True
Range("A3").PasteSpecial
Pfad = ActiveWorkbook.Worksheets("Tabelle2").Range("A" & t).Value
strFolder = "C:\Users\Win7ADM\Desktop\"
strPDFFile = strFolder & Pfad
ActiveWorkbook.FollowHyperlink Address:=strPDFFile, NewWindow:=True
SendKeys "^{DOWN}"
SendKeys "^{DOWN}"
SendKeys "^a", True
SendKeys "^c", True
SendKeys "%{F4}"
Range("A120").PasteSpecial
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
zeilemax = .Cells(Rows.Count, 1).End(xlUp).Row
For zeile = zeilemax To 1 Step -1
If .Cells(zeile, 1).Value Like "AA*" Or _
.Cells(zeile, 1).Value Like "Money*" Then
Else
.Rows(zeile).Delete
End If
Next zeile
End With
Application.ScreenUpdating = True
Range("A2:A150").Select ''Schreibt Text in Spalten nach Leerzeichen
Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1)), _
TrailingMinusNumbers:=True
Range("B1").Select
Selection.Copy
Workbooks.Open "C:\Users\Win7ADM\Desktop\Alle Ordner\ordner\Reports End\AA.xlsx"
Sheets("Money Manager").Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select ''sucht in Spalte A die nächste freie Zelle
ActiveSheet.Paste
Windows("Startdatei.xlsm").Activate '
Set RangeObj = Cells.Find(What:="AA", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If RangeObj Is Nothing Then MsgBox "AA nicht gefunden" Else RangeObj.Select ''sucht sich was er kopieren soll
ActiveCell.Offset(1, 5).Select
ActiveCell.Resize(1, 10).Cut
Windows("AA.xlsx").Activate
Sheets("Money Manager").Select
Cells(65000, 1).End(xlUp).Offset(0, 1).Select ''sucht in Spalte A die nächste freie Zelle und geht einen nach rechts
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows("Startdatei.xlsm").Activate
.
.
.
.
.