Paste Mthode funktioniert nicht immer
10.07.2020 08:54:27
Aurelia
ich habe ein Problem das ich selbst nicht lösen kann, ich hoffe, ihr könnt mir dabei helfen.
Ich habe eine Zieldatei, welche sich über einen Stündlichen Import Rohdaten importiert, und diese dann automatisch auswertet. Warum stündlich ? Weil die sich stündlich ändern und es um die Berechnung von Produktivitäten geht.
Die Stündliche Ausführung funktioniert über Application OnTime, über die dann einfach die beiden Makros aufgerufen werden. Das funktioniert einige Stunden sehr gut, und dann kommt ein Fehler bei der Paste Methode - ich versteh absolut nciht warum.
Hier der Code:
Der Timer, welcher die beiden unteren Makros aufruft:
Sub Timer()
Application.OnTime Now + TimeValue("00:15:00"), "Timer", Now + TimeValue("00:15:30")
Call Import
Call ImportOCS
End Sub
Import der Mengen Daten: (sind einzelne csv´s die geöffnet werden müssen, gesplittet werden, da die gesamte info in Zelle A1 steht, dann kopiert und eingefügt werden, und dann die Schrift weis gemacht wird)
Sub Import()
On Error GoTo ende
' Finde die richtige Datei (jeweils aktuellste des Tages, von allen erstellen
Dim lngZeile As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
'Definitionen für Split
Dim Zeile As Integer
Dim i As Integer
Dim EingefügteZellwerte() As String
Dim strQuelle As String
Dim strZiel As String
Dim Ziel, Quelle As Workbook
Set Ziel = ActiveWorkbook
strZiel = "ZielPfad"
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder("Verzeichnispfad")
Set objDateienliste = objVerzeichnis.Files
For Each objDatei In objDateienliste
If Not objDatei Is Nothing Then
'Öffnen und in Master Datei in erste freie Zeile einfügeen
ChDir "Verzeichnis"
Application.ScreenUpdating = False
Set Quelle = Workbooks.Open(objDatei)
Application.ScreenUpdating = False
'Split von Daten in die einzelenen Spalten
Zeile = 1
Do While Quelle.Sheets(1).Cells(Zeile, 1).Value ""
EingefügteZellwerte = Split(Quelle.Sheets(1).Cells(Zeile, 1).Value, ";")
For i = 0 To UBound(EingefügteZellwerte)
Quelle.Sheets(1).Cells(Zeile, i + 1).Value = EingefügteZellwerte(i)
Next i
Zeile = Zeile + 1
Loop
'Einfügen in Zieldatei in nächste freie Zeile
Quelle.Sheets(1).Range("A1:J18").Select
Application.ScreenUpdating = False
Selection.Copy
Application.DisplayAlerts = False 'Nicht Fragen ob Daten in zwischenablage behalten werden _
sollen - wird mit "Ja" beantwortet
Quelle.Close
'Windows("Zieldatei.xlsm").Activate 'Richtige Datei einfügen
Dim neueZelle As Range
'Ziel.Sheets ("MengenInput")
Set neueZelle = Ziel.Sheets("MengenInput").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'neueZelle.Select
'Debug.Print Ziel.Sheets("MengenInput").Range("A1").Value '.Range(neueZelle)
'Debug.Print
neueZelle.PasteSpecial
' Ziel.Sheets("MengenInput").Range(neueZelle).Paste
Ziel.Sheets("MengenInput").Range("D1:H500").Font.ColorIndex = 2 'Weiße Schriftfarbe für _
Datenschutz
objFileSystem.MoveFile objDatei, strZiel
End If
Next
ende:
End Sub
Das ist der Import der Zeit-Daten. Vom System wird automatisch immer eine CSV und eine Xslx erstellt, die CSV ist mir dabei egal, die wird einfach direkt verschoben, die XSLX wird geöffnet, kopiert und soll in die Zieldatei eingefügt werden. Hier beim Einfügen kommt der Fehler.
Sub ImportOCS()
'On Error GoTo ende
Dateienanzahl = 0
'CSV Dateien verschieben
Dim strQuelle As String
Dim strQuelleCSV As String
Dim strZiel As String
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder("Pfad wo die Dateien liegen")
Set objDateienliste = objVerzeichnis.Files
For Each objDatei In objDateienliste
If Not objDatei Is Nothing Then
endung = Right(objDatei.Name, 4)
If endung = ".csv" Then
'csv wegschieben
strZiel = "Pfad Ziel"
objFileSystem.MoveFile objDatei, strZiel
Dateienanzahl = 1
End If
End If
Next
If Dateienanzahl = 1 Then
'Vorhandene Daten löschen in Zieldatei
Application.ScreenUpdating = False
Windows("Experiment_Zieldatei.xlsm").Activate
Worksheets("OCS Daten").Activate
Range("D3:Z3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End If
' Finde die richtige Datei (jeweils aktuellste des Tages, von allen erstellen
Dim lngZeile As Long
For Each objDatei In objDateienliste 'xlsx importieren
If Not objDatei Is Nothing And Right(LCase(objDatei.Name), 5) = ".xlsx" Then
'Öffnen und in Master Datei in erste freie Zeile einfügen
Workbooks.Open Filename:=objDatei
Application.ScreenUpdating = False
Worksheets(1).Range("A2:I10000").Select
Selection.Copy
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'Nicht Fragen ob Daten in zwischenablage behalten werden _
sollen - wird mit "Ja" beantwortet
ActiveWorkbook.Close
Application.ScreenUpdating = False
Windows("Experiment_Zieldatei.xlsm").Activate 'Richtige Datei einfügen
Application.ScreenUpdating = False
Worksheets("OCS Daten").Activate
Application.ScreenUpdating = False
Range("D3").Select
ActiveSheet.Paste Destination:=Worksheets("OCS Daten").Range("D3") 'erst ab D3 einfügen
Application.ScreenUpdating = False
'XslX Dateien Verschieben in Archiv
objFileSystem.MoveFile objDatei, strZiel
Application.ScreenUpdating = True
End If
Next
Set objFSO = Nothing
ThisWorkbook.Save
'ende:
End Sub