Office: (Office 2013) bestehendes Tabellenblatt-kopier-Makro auf Spalten-kopieren ändern

Hallo,
ich habe da eine (hoffentlich)klene Frage:

Ich abe ein Makro im Internet gefunden das bisher meinen Wünschen entspricht. Das Makro kopiert ganze Tabellenblätter aus mehreren Dateien in eine Zusammenfassung. Dazu fragt es wo die Dateien gespeichert sind, und gibt den neuen Tabellenblätter in der neuen Datei den Dateinamen als Sheetnamen. Funktionier talles tadellos.

Nun bräuchte ich eine Änderung die mir aus einem Tabellnblatt (erstes Tabellenblatt in allen Dateien genant "Wochenansicht") nur die komplette Spalten L und M kopiert. Habe schon mit allen Änderungen die ich gefunden habe versuct das Makro umzuschreiben (Column; Range, selection,...) bekomme dan aber ur Fehlermeldungen.
Leere Zeilen sollen mitkopiert werden.

Kann mir jemand helfen? Bin in VBA ein blutiger Anfänger. Habe Office 2013

Zur Info: Die Dateien sind eine AUflistung von Messwerten je Kalenderwoche im 4 Sekundentakt. Das bedeutet dass die Datein zimlich groß sind (je Woche 151200 Werte). Also müsten auch die SPalten nur bis dahin kopiert weden. Hoffe das macht keine Probleme.

Hier das Makro

Code:

Sub kopie()
 Dim oTargetBook As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
   Dim oFileDialog As FileDialog

     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen

     'Schritt 1: Arbeitsmappe festlegen, in die die neuen Sheets eingefügt werden...
     Set oTargetBook = ActiveWorkbook

     'Wichtiger Hinweis: Die Arbeitsblätter dürfen nicht vorhanden sein!
     'Alternativer Umbau: Löschen evtl. bereits vorhandener Arbeitsblätter

     'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
     Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
     With oFileDialog
        .Title = "Importverzeichnis wählen..."
        .ButtonName = "Import"
        If .Show = -1 Then sPfad = .SelectedItems(1)
     End With
     If Trim(sPfad) = "" Then Exit Sub
     If Right(sPfad, 1) <> "\" Then sPfad = sPfad & "\"
     sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien

     Do While sDatei <> ""

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen

         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
         oSourceBook.Sheets(3).Copy after:=oTargetBook.Sheets(oTargetBook.Sheets.Count)
         ActiveSheet.UsedRange.Cells = ActiveSheet.UsedRange.Cells.Value

         'Es wird versucht den Dateinamen als Arbeitsblattnamen zu setzen.
         'Ist dieser bereits vorhanden wird der Fehler abgefangen und das neue Blatt
         'bekommt keinen anderen Namen und behält den typischen Namen Tabelle x
         On Error Resume Next

         'Arbeitsblattname wird der Dateiname
         oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = sDatei

         'Wenn ein Fehler aufgetreten ist, wird dieser resettet
         If Err.Number <> 0 Then
            Err.Number = 0
            Err.Clear
         End If
         On Error GoTo 0

         'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
         oSourceBook.Close False 'nicht speichern

         'Nächste Datei
         sDatei = Dir()

     Loop

     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
     Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen

     'Kleine finale Fertig-Meldung
     MsgBox "Fertig!", vbInformation + vbOKOnly, "Hinweis!"

     'Variablen aufräumen
     Set oTargetBook = Nothing
     Set oSourceBook = Nothing
End Sub

 

Hallo ahalbeu,

zuersteinmal ist mir folgendes aufgefallen:

Die "3" im Code müsste in eine "1" geändert werden, wenn wirklich immer auf das erste Blatt der Dateien zugegriffen werden soll.


Als zweites ist mir aufgefallen, dass in Deinem Makro Systemeinstellungen verändert werden, ohne diese Veränderungen durch eine ordentliche Fehlerbehandlung abzusichern, bzw. vorher überhaupt ersteinmal zu prüfen wie diese Einstellungen aktuell überhaupt stehen:

Code:

     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen

Das kann man so machen, sollte man sich aber eigentlich garnicht erst angewöhnen.
;O)


Als drittes ist mir aufgefallen, dass Du mit der Zeile:

Code:

         ActiveSheet.UsedRange.Cells = ActiveSheet.UsedRange.Cells.Value

eventuelle Formeln etc. in Werte umwandelst.
Ist das notwendig? Sind die Messreihen nicht eh schon reine Werte?
Obendrein sollte man "ActiveSheet" eigentlich nur benutzen, wenn es sich garnicht vermeiden lässt, bzw. vor allem auch nur, wenn man sich absolut sicher sein kann, welches Blatt gerade das aktive ist. Eine definierte Referenzierung ist deshalb immer vorzuziehen.


Und als viertes ist mir aufgefallen, dass Du überhaupt nicht schreibst, wohin die beiden Spalten L und M kopiert werden sollen.
Sollen Sie wieder in L und M? Oder in A und B?


Aber nun zu meinem Lösungsvorschlag:

Code:

     Do While sDatei <> ""

[COLOR=#ff0000]         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)[/COLOR]

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
         oSourceBook.[COLOR=#ff0000]Work[/COLOR]sheets(1)[COLOR=#ff0000].Range("L:M")[/COLOR].Copy [COLOR=#ff0000]Destination[/COLOR]:=oTargetBook.[COLOR=#ff0000]Work[/COLOR]sheets(oTargetBook.Worksheets.Count)[COLOR=#ff0000].Range("L:M")[/COLOR]
         [COLOR=#ff0000]oTargetBook.Worksheets(oTargetBook.Worksheets.Count)[/COLOR].UsedRange.Cells = [COLOR=#ff0000]oTargetBook.Worksheets(oTargetBook.Worksheets.Count)[/COLOR].UsedRange.Cells.Value

Da ich nicht weiß, welche Zelldetails Du alle benötigst (ich kenne Deine Datei nicht), habe ich beim obigen Vorschlag Deine Kopiermethode übernommen.
Effektiver wäre aber sicherlich, auf das nachträgliche ändern in Zellwerte zu verzichten (falls überhaupt notwendig) und direkt nur Zellwerte (und eventuell Formate) zu übertragen:

Code:

     Do While sDatei <> ""

         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
         oSourceBook.Worksheets(1).Range("L:M").Copy
         [COLOR=#ff0000]oTargetBook.Worksheets(oTargetBook.Worksheets.Count).Range("L:M").PasteSpecial Paste:=xlPasteValuesAndNumberFormats[/COLOR]

Und falls das ändern in Zellwerte eh überflüssig ist, benutze die obere Lösung (copy destination) und lass einfach die Zeile darunter weg.
;O)





Nachtrag:
Willst Du wirklich auch die Dateiendung im Arbeitsblattnamen? Sollte die nicht mit "split" vorher entfernt werden?

 

Hallo,
danke für die erste Antwort.
Zu deinen Anmerkungen:

1.Das mit dem ersten Tabellnblat ist bekannt. Habe bei er anderen Kopieraktion das dritte benötigt, daher stet das noch so drinnen.

2. Das mit den Fehlermeldungen ist so ne Sache. Ich habe in der Quelldatei Zellbezügezu anderen Dateien. Beim öfnen kommt imer die Meldung mit dem aktualisieren. Ob das jetzt eine so ausgeschaltete Fehlermeldung ist, weis ich nicht (bin blutiger VBA-Anfänger). Bei der anderen Kopieraktion hat das wunderbar geklappt, deswegen wollte ich das Makro eigentlich so wie es ist gröstenteils stehen lassen.

3. Ich brauche keine Formeln, nur die Werte da Zelle L und M aus anderen Werten der Quelldatei berechnet werden. beides sind Zahlen die auf Stanartformat der Zellen eingestellt sind

4. Wie müsste ich das umschreiben? Dachte eigentlich durch den vorherigen öffnn Befehl ist das soweit klar. WIe gesagt,hat bisher alles wunderbar funtioniert, auch wenn ich die gesamten Tabellenblätter kopiereklppt das. brauch aber fü meine weitere Auwertung eigentlich nur Spalte L und M

5. wo die dann tehen ist eigenlich egal, Würde Spalte B und D (wenns einfacher ist auch B/C oder sogar A/B gehen), ist eigentlich schnurz, da ich die Werte nur sammeln und vergleichen will/muss

6. was meinst du mit Zelldetails? ich brauche lediglich die Werte aus den Spalten. Sind beides Zahlenwerte, also kann auch das Format in der neuen Datei auf standart bleiben. Ich glaube für die nächste kopieraktion muss ich das Format mit übertragen (Datum und Uhrzeit). Was wird denn in meinem Makro an Zellwerten geändert? (Blutiger VBA-Anfänger)


7. der Dateiname als Tabellenname fand ich gut, meine Dateien heisen KW 01 bis KW 53, Tabellen heisen dann eben KW 1.xlsx... das ist mir schnurz, wär naürlich schöner wenns nu KW 01 bis KW 52 heisen würden. Hab das Makro eben so fertig gefunden, und selbst das mit der Namensgebung fand ich sehr passend.

werde die vorgeschlagenen Änderungen später mal testen, und mich nochmal melden

Danke schonmal im vorraus, bis dann

 

Wie gesagt, kannst Du ja auch.
Nur würde ich es nicht uneingeschränkt empfehlen.
Der beste Weg wäre, erstmal durch das Makro zu prüfen, welchen Wert diese beiden Einstellungen aktuell haben, und diese beiden Werte in Variablen "zu speichern". Dann die Einstellungen so ändern wie Du möchtest, und am Ende des Makros die Einstellungen wieder auf den Urzustand bringen (die ursprünglichen Werte hast Du ja noch in den Variablen).
Und damit das System nicht unbeabsichtig verändert bleibt, falls das makro (egal warum) doch einmal abschmiert und nicht korrekt bis zum Ende durchläuft, baut man das ganze in eine Fehlerbehandlung ein, die im Falle von nicht verarbeiteten Fehlern dafür sorgt, dass die Einstellungen wieder in den ursprünglichen Zustand versetzt werden.
Aber wie gesagt, muss man nicht machen.
;O)

Dachte ich mir. Dann kannst Du Dir diese Zeile auch sparen:

Code:

ActiveSheet.UsedRange.Cells = ActiveSheet.UsedRange.Cells.Value

Mit Zelldetails meinte ich Formatierungen, Hyperlinks, Formeln usw....

Am Dateinamen als Blattnamen ist auch überhaupt nichts auszusetzen. Ich habe auf die Dateiendung aufmerksam gemacht.
;O)
Wenn Du die weghaben möchtest, könnte man den Code so schreiben:

Code:

         'Arbeitsblattname wird der Dateiname
         oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = Left(sDatei, InStrRev(sDatei, ".") - 1)

(mit "Split" habe ich mich vertan, "InstRev" ist besser geeignet)

 

Hallo,

erstmal vielen Dank, klappt super. (Ich war nah dran an der Lösung, einzig das "Work" vor den Sheets im Kopierbefehl hat gefehlt. Was da jetzt der Unterschied ist, weis ich nicht, wäre aber gut zu wissen, da der blutiger Anfänger zum wissbegierigem Lehrling geworden ist ;) )

Ich hab zusätzlich noch ein paar Änderungen gemacht.

1. Ich lasse 2 Kopierbefehle in der Schleife durchlaufen: einmal Spalte A und B (Datum und Uhrzeit) in Spalte A und B (Werte und Format) und dann Spalte N und O in Spalte C und D (nur Werte)

2. habe ich mit dem Splitbefehle gearbeitet. es scheint dennoch zu funktioniern ( mit 2 Dateien getestet) Mein splt und Namensbefehl sieht dann so aus

Code:

TName = Split(sDatei, ".")(0)
         
         
         oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = TName

(natürlich noch TNme als String festlegen)

was gibts denn an Split auszuseten? Werde den InstRev Befehl verwenden, bin aber Lehrling und würde gern den Unterschied wissen (Antwort auf Lehrlingsniveu)

Mein ganzer Code sieht nu so aus

Code:

] Sub kopie()
 Dim oTargetBook As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
   Dim oFileDialog As FileDialog
   
   

     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen

     'Schritt 1: Arbeitsmappe festlegen, in die die neuen Sheets eingefügt werden...
     Set oTargetBook = ActiveWorkbook

     'Wichtiger Hinweis: Die Arbeitsblätter dürfen nicht vorhanden sein!
     'Alternativer Umbau: Löschen evtl. bereits vorhandener Arbeitsblätter

     'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
     Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
     With oFileDialog
        .Title = "Importverzeichnis wählen..."
        .ButtonName = "Import"
        If .Show = -1 Then sPfad = .SelectedItems(1)
     End With
     If Trim(sPfad) = "" Then Exit Sub
     If Right(sPfad, 1) <> "\" Then sPfad = sPfad & "\"
     sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien

     Do While sDatei <> ""

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
         oSourceBook.Worksheets(1).Range("A:B").Copy Destination:=oTargetBook.Worksheets(oTargetBook.Sheets.Count).Range("A:B")
         oTargetBook.Worksheets(oTargetBook.Worksheets.Count).UsedRange.Cells = oTargetBook.Worksheets(oTargetBook.Worksheets.Count).UsedRange.Cells.Value
         
         oSourceBook.Worksheets(1).Range("N:O").Copy
         oTargetBook.Worksheets(oTargetBook.Worksheets.Count).Range("C:D").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
         'Es wird versucht den Dateinamen als Arbeitsblattnamen zu setzen.
         'Ist dieser bereits vorhanden wird der Fehler abgefangen und das neue Blatt
         'bekommt keinen anderen Namen und behält den typischen Namen Tabelle x
         On Error Resume Next

         'Arbeitsblattname wird der Dateiname
                
         
         oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = Left(sDatei, InStrRev(sDatei, ".") - 1)

         'Wenn ein Fehler aufgetreten ist, wird dieser resettet
         If Err.Number <> 0 Then
            Err.Number = 0
            Err.Clear
         End If
         On Error GoTo 0

         'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
         oSourceBook.Close False 'nicht speichern

         'Nächste Datei
         sDatei = Dir()

     Loop

     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
     Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen

     'Kleine finale Fertig-Meldung
     MsgBox "Fertig!", vbInformation + vbOKOnly, "Hinweis!"

     'Variablen aufräumen
     Set oTargetBook = Nothing
     Set oSourceBook = Nothing
End Sub 

 

Hallo ahalbeu,

an "Split" gibt es garnix auszusetzen.
;O)
Aber es arbeitet anders als die Version mit "InstRev".
Mit "InstrRev" wird alles bis zu dem ersten "." von rechts ausgegeben, also der komplette Name ohne Endung.
Das klappt auch, falls jemand mal einen "." mitten im Dateinamen benutzt.
Mit "Split" geht das nicht so einfach.

Lass einfach mal den folgenden Code bei Dir laufen, dann siehst Du den Unterschied:

Code:

Public Sub SplitUndInstrRev()

Dim sDatei As String

    sDatei = "Quelle.Test.xls"
    
    MsgBox Split(sDatei, ".")(0)
    MsgBox Left(sDatei, InStrRev(sDatei, ".") - 1)

End Sub

 

Hallo nochmal.

Habe das Makro jetzt durhlaufen lassen, un ist es währen der 5ten Datei zu einem Fehler gekommen.

"Laufzeitfehler 9 - Index außerhalb des gültigen Bereiches"

markiert wird folgende Codezeile (nach drücken von Debuggen)

Code:

oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)

Was ist der Fehler und was ist zu tun?

 

Nachtrag:

Code:

Set oTargetBook = ActiveWorkbook

würde ich durch

Code:

Set oTargetBook = ThisWorkbook

ersetzen (Begründung siehe weiter oben)



Mit

Code:

If Trim(sPfad) = "" Then Exit Sub

beendest Du das Makro, ohne die anfänglich veränderten Einstellungen wieder zurück zu setzen.
Besser wäre zum Beispiel die Benutzung einer Sprungmarke:

Code:

If Trim(sPfad) = "" Then GoTo Beenden

und dann ganz unten:

Code:

     Loop

[COLOR=#ff0000]Beenden:[/COLOR]
     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
     Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen
     
     [COLOR=#ff0000]If Trim(sPfad) = "" Then Exit Sub[/COLOR]

     'Kleine finale Fertig-Meldung
     MsgBox "Fertig!", vbInformation + vbOKOnly, "Hinweis!"

     'Variablen aufräumen
     Set oTargetBook = Nothing
     Set oSourceBook = Nothing
End Sub

Und den Kopiervorgang für die Spalten "A:B" würde ich so machen:

Code:

         oSourceBook.Worksheets(1).Range("A:B").Copy
         oTargetBook.Worksheets(oTargetBook.Worksheets.Count).Range("A:B").PasteSpecial Paste:=xlPasteValues

Damit sparst Du Dir die verwendung von "UsedRange" (ist in Deinem Fall nicht unbedingt sinnvoll), und vor allem sparst Du Dir ein unnötiges Ändern von Zellen. Das verlangsamt nur.

 

Wieviele Blätter hat Deine Datei denn bereits?

 

da die Mappe leer war, hatte Sie beim start des Makros nur 1, dann hat es 4 Tabellenbläter kopiert und beim 5ten kam der Fehler

als ich das makro mit ganzen tabellenblättern schon erfolgreich enutzt habe, hatte ich insgesamt 54 tabellenblätter (aber it weniger Zeilen)
ist de Datei etwa zu Groß?

Nachtrag:
Händisch kann ich es einfügen. Wenn ich das Makro laufen lasse dann öffnet er die quelldatei und haut dann en Fehler raus

 

Das sollte nicht der Grund sein, ich habe schon mit Mappen mit mehreren Hundert Arbeitsblättern gearbeitet. Wollte nur sicher gehen.

Kannst Du bitte Deine Zieldatei und eine Quelldatei hier im Forum hochladen, damit man den Fehler nachvollziehen kann?
Anonymisiere an Daten, was nicht öffentlich gehört, und begrenze die Anzahl der Datensätze auf max. 100 oder weniger, das reicht.

 

Die Zeile die den Fehler ausgibt habe ich auf dein Anraten hin eingefügt( leeres Tabelenblattt am Ende erstellen). Habe die Zeile entfernt, da das Makro auch vorher schon ohne Probleme gelaufen ist. nach ersten Tests hat es geklappt, habe das Makro jetzt gestartet, und es arbeitet seit einer halben stund e ohne Fehler. Ma kucken was dabei rauskommt. Danach kann ich eine Testdatei gerne hochladen, die Daten sind sowieso öffentlich im Internet zugänglich.

 

Na da bin ich ja mal gespannt...
denn wenn Du

Code:

oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)

entfernst, müsten Deine Daten immer in das selbe Blatt geschrieben, und somit jedesmal überschrieben werden...
Übrigens hat diese Zeile bei mir keinerlei Probleme verursacht.
;O)

 

... ähm ja...die Stunde Bearbeitungszeit hätte ich mir auch schnken könne wenn ich nicht so voreilig gewesen wäre.

aber, wahrscheinlich hat das Makro funktioniert, da die Daten der letzen Quelldatei auf das Tabelenblatt kopiert wurden

den Befehl habe ich erst auf dein anraten eingefügt, finden keinen gleichwertigen Befehl in meiner ursprungsdatei, die auch (wenn auch anders) funktionier hat. Oder ist in meinem Ursprungsmakro zwischenzeitlich "oTargetBook.Sheets.Count" das mein neu erstelltes sheet bevor es umbenannt wird?

Quelldatei folgt

 

Hallo ahalbeu,

ich denke ich habe den Fehler gefunden.
Du hast den Code, den ich Dir vorgeschlagen habe, nicht 1 zu 1 übernommen, sondern die Reihenfolge der Codezeilen verändert.

Mein Code:

Code:

         Do While sDatei <> ""

         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!

Dein Code:

Code:

         Do While sDatei <> ""

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!

Der Unterschied ist klein aber fein.
Sobald das Makro eine Datei öffnet, wird diese zum "ActiveWorkbook".
Und sobald die Quelldatei geschlossen wird, sollte eigentlich die Zieldatei wieder den Focus erhalten.
Somit ist bei Deinem Code die Zieldatei im Moment wo das neue Blatt erstellt wird, nicht die aktive Datei.
Neue Arbeitsblätter in einer Datei hinzufügen klappt meines Wissens nach aber nur im "ActiveWorkbook" wirklich fehlerfrei.
Warum der Fehler nicht immer, sondern nur ab und zu auftaucht weiß ich nicht, hatte das Problem aber selber schonmal.
Eigentlich sollte es bei meiner Reihenfolge keine Probleme geben. Aber falls Du dann immernoch Fehlermeldungen bekommst, kannst Du folgendermaßen auf Nummer sicher gehen:

Code:

      Do While sDatei <> ""

         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         [COLOR=#ff0000]oTargetBook.Activate[/COLOR]
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!

Damit es für Dich übersichtlicher wird, hier mal der komplette Code:

Code:

Sub kopie()
   Dim oTargetBook As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
   Dim oFileDialog As FileDialog

     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen

     'Schritt 1: Arbeitsmappe festlegen, in die die neuen Sheets eingefügt werden...
     Set oTargetBook = ThisWorkbook

     'Wichtiger Hinweis: Die Arbeitsblätter dürfen nicht vorhanden sein!
     'Alternativer Umbau: Löschen evtl. bereits vorhandener Arbeitsblätter

     'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
     Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
     With oFileDialog
        .Title = "Importverzeichnis wählen..."
        .ButtonName = "Import"
        If .Show = -1 Then sPfad = .SelectedItems(1)
     End With
     If Trim(sPfad) = "" Then GoTo Beenden
     If Right(sPfad, 1) <> "\" Then sPfad = sPfad & "\"
     sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien

      Do While sDatei <> ""

         ' ein neues Arbeitsblatt in der Zieldatei erstellen (immer an letzter Stelle)
         oTargetBook.Activate
         oTargetBook.Worksheets.Add After:=Worksheets(oTargetBook.Worksheets.Count)

         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
         oSourceBook.Worksheets(1).Range("A:B").Copy
         oTargetBook.Worksheets(oTargetBook.Worksheets.Count).Range("A:B").PasteSpecial Paste:=xlPasteValues
         oSourceBook.Worksheets(1).Range("L:M").Copy
         oTargetBook.Worksheets(oTargetBook.Worksheets.Count).Range("L:M").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

         'Es wird versucht den Dateinamen als Arbeitsblattnamen zu setzen.
         'Ist dieser bereits vorhanden wird der Fehler abgefangen und das neue Blatt
         'bekommt keinen anderen Namen und behält den typischen Namen Tabelle x
         On Error Resume Next

         'Arbeitsblattname wird der Dateiname
         oTargetBook.Worksheets(oTargetBook.Worksheets.Count).Name = Left(sDatei, InStrRev(sDatei, ".") - 1)

         'Wenn ein Fehler aufgetreten ist, wird dieser resettet
         If Err.Number <> 0 Then
            Err.Number = 0
            Err.Clear
         End If
         On Error GoTo 0

         'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
         oSourceBook.Close False 'nicht speichern

         'Nächste Datei
         sDatei = Dir()

     Loop

Beenden:
     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
     Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen
     
     If Trim(sPfad) = "" Then Exit Sub

     'Kleine finale Fertig-Meldung
     MsgBox "Fertig!", vbInformation + vbOKOnly, "Hinweis!"

     'Variablen aufräumen
     Set oTargetBook = Nothing
     Set oSourceBook = Nothing
End Sub