Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1456to1460
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

Kopiere ersten .sheets, anfügen in neuer Mapp

Kopiere ersten .sheets, anfügen in neuer Mapp
14.11.2015 20:03:31
Exel
Hallo,
Ich versuche schon seid einiger Zeit mit den Makro Aufzeichner weiter zu kommen, aber selbst das simple Makieren einer Zelle und dessen Inhalt Kopieren und in einem neuen Blatt einfügen scheitert kläglich!
Zu meinem Problem,
ich habe einen Ordner (Abrechnung) in diesem sind Unterordner (Jan, Feb, Mär, Apr..)
darin sind dateien im *xls format gespeichert und enthalten mehere .sheets!
Nun möchte ich aus jeder Datei das erste .sheet (Rechnung) kopieren und in meiner Übersicht einfügen rechnung1, rechnung2, rechnung3...
Natürlich erwarte ich nicht eine Fix und Fertig lösung, kann aber auch nicht wirklich gut VBA, meine stärken sind ehr SQL
grüsse

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
14.11.2015 20:27:00
Sepp
Hallo ? (ein Name macht das ganze gleich freundlicher!)
ohne Prüfung, ob ein entsprechendes Blatt schon besteht!
Code in ein allgemeines Modul einfügen und das Startverzeichnis anpassen.
' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySheets()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long

On Error GoTo ErrorHandler

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

strPath = "E:\Forum" 'Start-Verzeichnis - Anpassen!

lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)

If lngRes <> 0 Then
  For lngIndex = 0 To UBound(objFiles)
    Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
    objWB.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "Rechnung " & lngIndex + 1
    objWB.Close False
  Next
End If

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - copySheets"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
  Optional ByVal SubFolders As Boolean = False) As Long


'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant

Set fobjFSO = CreateObject("Scripting.FileSystemObject")

Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
  varFiles = Split(FileName, ";")
Else
  Redim varFiles(0)
  varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
  If Not ffsoFile Is Nothing Then
    For intC = 0 To UBound(varFiles)
      If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
        If IsArray(Files) Then
          Redim Preserve Files(UBound(Files) + 1)
        Else
          Redim Files(0)
        End If
        Set Files(UBound(Files)) = ffsoFile
        Exit For
      End If
    Next
  End If
Next

If SubFolders Then
  For Each ffsoSubFolder In ffsoFolder.SubFolders
    FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
  Next
End If

If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
14.11.2015 20:32:37
Exel
Supper Sepp,
danke für die Schnelle antwort!
Ich kann das leider erst morgen testen da auf dem Notebook nur Libre läuft :(
grüsse

AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 11:03:40
Herbert
Hallo Sepp,
was ist das eigentlich für ein geiles Teil, mit dem du den Code so klasse darstellen kannst?
Servus

AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 11:22:33
Sepp
Hallo Herbert,
das Tool das ich verwende ist von Peter Haserodt.
Download: http://www.haserodt.de/index.php?site=501
Auch Hajo bietet auf seiner Seite ein ähnliches Tool an.
Gruß Sepp

Anzeige
Danke! owt
15.11.2015 11:35:26
Herbert
,,

Der Nachteil von so etwas ist, ...
15.11.2015 13:25:56
so
…Herbert,
dass die ForumsSoftware darauf nicht mit Icon in der BetreffZeile reagieren kann, weil es formatiertes HTML ist! Im Gegensatz zur HTML-Darstellung von Tabellen ist so ein Tool 'ne (fast) reine Spielerei (weshalb ich mir auch nicht die Mühe machen würde, so etwas zu pgmmieren).
Gruß, Luc :-?

Danke, Luc owt
15.11.2015 13:30:57
Herbert
,,

AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 12:09:04
Exel
Guten Tag Sepp,
also, soweit funktioniert es :D
Leider ist mir erst jetzt aufgefallen das ich etwas ältere Dateien im xls format gespeichert habe und neuere Dateien im xlsx gespeichert habe sodass wenn ich
lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)

auf

lngRes = FileSearchINFO(objFiles, strPath, "*.xlsx", True)

ändere, schliesst Exel einfach wenn ich das Makro starte!
grüsse
Ps. sorry wegen dem Namen ich dachte er zeigt beides im Forum an, kann es aber auch im Profil nicht ändern... ich bin der John

Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 13:08:42
Sepp
Hallo John,
wenn du alle xl-Dateiformate einlesen willst, dann so.
lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)

Warum sich Excel dabei schließen soll, kann ich nicht nchvollziehen.
Gruß Sepp

Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 13:29:54
Exel
Hallo Sepp,
Ich habe es schon ein wenig angepasst und mit meinen alten Daten funktioniert es auch mit den Indirekt sachen was ich vor habe soweit, dieses sind jedoch nur 5 Dateien die mir mit
lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)

Problemlos angezeigt werden.
Wie jedoch erwähnt habe ich depp natürlich die neuen schon im .xlsx format, warum auch immer... verwende office 2010, und könnte die Dateien auch im 97 format speichern, was sich aber dann hinzieht wie eine Gurke :)
Meine befürchtung ist wenn dann alle .xl* formate eingelesen werden dann auch die Kunden Datei und die eigentliche Vorlage mit kopiert werden.
Aber leider funktionert die von dir vorgeschlagene änderung
lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)

nicht... er macht den anschein als würde er mir die 6 alten dateien öffnen.
' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
Option Explicit
Sub Löschen()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
End Sub
Sub Erstellen()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long
On Error GoTo ErrorHandler
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!
lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)
If lngRes  0 Then
For lngIndex = 0 To UBound(objFiles)
Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
ErrorHandler:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" _
findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
grüsse john
[edit] Hab im Editor mal auf zurücksetzen gemacht und nochmal gestartet, er macht rein garnix :( [/edit]

Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 14:48:26
Sepp
Hallo John,
kommt eine Fehlermeldung? Kann das nicht nachvollziehen.
Gruß Sepp

AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 14:56:22
Exel
Nein, es passiert einfach garnix!
' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
Option Explicit
Sub Löschen()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
End Sub
Sub Kopieren()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long
On Error GoTo ErrorHandler
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.Application.AskToUpdateLinks = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!
lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)
If lngRes  0 Then
For lngIndex = 0 To UBound(objFiles)
Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
ErrorHandler:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" _
findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Sub Start()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
Call Kopieren
End Sub
Hab es jetzt ein wenig angepasst das wenn ich es Starte er mir die RE Blätter löscht und dann das Kopieren anfängt (hier habe ich auch in deinem Makro geändert das er keine Fehlermeldung gibt wenn es externe verlinkung vorhanden sind), oder aber ich auswählen kann das nur die RE gelöscht werden!
Das Problem war aber auch schon mit der ersten Version von dir und die änderung, leider!
grüsse john

Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 16:44:06
Sepp
Hallo John,
hast du Excel schon mal beendet und neu gestartet?
Gruß Sepp

AW: Kopiere ersten .sheets, anfügen in neuer Mapp
16.11.2015 17:58:22
Exel
Hallo Sepp,
anscheind funktioniert es jetzt mit der änderung...
Danke erst mal ganz herzlichst soweit!
Nun ist es so das aufgrund des formats einige Dateien mit eingelesen werden die nicht mit rein sollen!
Ich habe dann im netz etwas gefunden und etwas angepasst, aber leider bekomme ich es nicht zum laufen...
Denke das die $vars nicht passen, wie müsste es richtig heissen?
If lngRes  0 Then
For lngIndex = 0 To UBound(objFiles)

  If Not lngIndex Like "Datei1*" Or lngIndex Like "Datei2*" Then   '"Mappe*"
If Not SourceFolder.Path & "\" & lngIndex = ThisWorkbook.FullName Then Workbooks.Open SourceFolder.Path & "\" & lngIndex

    Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
grüsse John

Anzeige
AW: Kopiere ersten .sheets, anfügen in neuer Mapp
17.11.2015 18:06:58
John
Hmm, ich scheitere an der angabe der richtigen Variablen! :(
*verzweifeltguck*
Grüsse John

AW: Kopiere ersten .sheets, anfügen in neuer Mapp
17.11.2015 18:26:19
Sepp
Hallo John,
'lngIndex' ist eine Zählvariable, du kannst nicht den Dateinamen mit einem Zähler vergleichen!
Sub Kopieren()

Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long

On Error GoTo ErrorHandler

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .Application.AskToUpdateLinks = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!

lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)

With ThisWorkbook
  If lngRes <> 0 Then
    For lngIndex = 0 To UBound(objFiles)
      If Not objFiles(lngIndex).Name Like "Datei1*" Or objFiles(lngIndex).Name Like "Datei2*" Then '"Mappe*"
        If Not objFiles(lngIndex).Path = .FullName Then
          Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
          objWB.Sheets(1).Copy After:=.Sheets(.Sheets.Count)
          .Sheets(.Sheets.Count).Name = "RE" & lngIndex + 1
          objWB.Close False
        End If
      End If
    Next
  End If
End With

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - copySheets"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub


Gruß Sepp

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige