AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 14:25:01
kathrin
Hallo Franz,
erstmal vielen Dank für deine bisherige Hilfe.
Ich dachte nicht, dass sich das integrieren für mich als so schwer erweisen würde, als ich die Frage ins Forum stellte, da ich im letzten halben Jahr mich mehr mit Makros befasst habe und dachte mein Kenntnisstand würde ausreichen.
Doch ich habe jetzt leider keine Ahnung wo ich Teile deines Makros einbauen soll. Kannst du mir dabei noch helfen?
Die Zusammenfassungsdatei erkennt selbst wo sie liegt und die Namen der Dateien, die sie durchsuchen soll. Auf einem Tabellenblatt wird eingetragen aus welchem Tabellenblatt der Grunddaten welche Zelle übertragen werden soll. Ich vermute es müsste dort dazugefügt werden, was ich jetzt fett und kursiv hervorgehoben habe.
Option Explicit
Private wbZiel As Workbook
Private wksZiel As Worksheet
Private wksSteuer As Worksheet
Private Zeile As Long, sZelle As String, Spalte As Long
'#### Sub-Routine zum Auslesen von Dateinamen in einem Ordner, Optional inkl. Unter-Ordner
'Quelle: https://www.herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: fcs 2010-08-07
Public plCount As Long, parrFiles() As String
Public Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, _
Optional FolderName As Boolean = False)
'SourceFolderName = Ordner, wo soll gesucht werden?
'DateiFormat = Like-Vergleich für Dateinamen, * als Platzhalter verwenden, Optional - _
leer ist alle
'IncludeSubfolders = Unterordner mit durchsuchen - True = Ja , False = Nein, Optional
'FolderName = Dateiname inkl. Pfad ausgeben - True = Ja, False = Nein, Optional
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - optional inkl. Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
'*******************************weitere Eigenschaften ********
'Name: FileItem.Name
'Pfad mit Dateiname: FileItem.Path
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
plCount = plCount + 1
ReDim Preserve parrFiles(1 To plCount)
parrFiles(plCount) = IIf(FolderName, FileItem, FileItem.Name)
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
'### Zusammenfassung: Altdaten löschen, Daten aus den Dateien auslesen und in Zusammenfassung einfügen ###
Sub Zusammenfassung_Erstellen()
Dim strOrdner As String
Dim lFile As Long, StatusCalc As Long
Dim ZeileLetzte As Long
Dim lngZeile1 As Long
On Error GoTo Fehler
Set wksSteuer = ThisWorkbook.Worksheets("Steuerung")
'Zieldatei/-Tabellenblatt setzen
Set wbZiel = ThisWorkbook
Set wksZiel = wbZiel.Worksheets("Zusammenfassung") 'Name des Zielblatts ggf. anpassen
'1. Zeile in die Daten in der Zusammenfassung eingetragen werden
lngZeile1 = wksZiel.Range("Zeile_Daten_1").Row
'zu durchsuchendes Verzeichnis gleich dem Ordner dieser Datei setzen
strOrdner = wbZiel.Path
wksSteuer.Range("Verzeichnis") = strOrdner
StatusCalc = Application.Calculation 'Berechnungsmethode merken
'Altdaten unterhalb der Spaltentitel in Zieltabelle löschen
With wksZiel
'Letzte Datenzeile in Zusammenfassung in Spalte A
With .UsedRange
ZeileLetzte = .Row + .Rows.Count - 1
End With
If ZeileLetzte >= lngZeile1 Then
'Hyperlinks und Inhalte löschen
.Range(.Rows(lngZeile1), .Rows(ZeileLetzte)).ClearContents
End If
ZeileLetzte = lngZeile1 - 1
End With
'Dateiliste zurücksetzen
plCount = 0
Erase parrFiles
'Dateiliste erstellen
Call ListFilesInFolder(SourceFolderName:=strOrdner, _
DateiFormat:="*.xls*", _
IncludeSubfolders:=wksSteuer.Range("Unterverzeichnisse") = "Ja", _
FolderName:=True)
If plCount
MsgBox "Keine Kalkulationsdateien im Verzeichnis """ & strOrdner & """ gefunden", _
vbInformation, "Z U S A M M E N F A S S U N G erstellen"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'gefundene Dateien abarbeiten
For lFile = 1 To plCount
If fncCheckOeffnen(parrFiles(lFile)) = True Then
Application.StatusBar = "Bearbeite Datei " & lFile & " von " & plCount & "," _
& parrFiles(lFile)
ZeileLetzte = ZeileLetzte + 1
Call Daten_Auslesen(sFilename:=parrFiles(lFile), ZeileZiel:=ZeileLetzte)
End If
Next
'Summenzeile gemäß Vorgaben im Blatt Steuerung im Zielblatt einfügen
ZeileLetzte = ZeileLetzte + 2 'eine Leerzeile lassen
With wksSteuer
For Zeile = .Range("StartListe").Row + 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
Spalte = .Cells(Zeile, 4).Value
sZelle = .Cells(Zeile, 5).Text
With wksZiel.Cells(ZeileLetzte, Spalte)
Select Case sZelle
Case ""
Case "Formel"
.FormulaR1C1 = "=SUM(R" & lngZeile1 & "C:R[-2]C)"
Case Else
.Value = sZelle
End Select
End With
Next
End With
'Druckbereich anpassen
With wksZiel
With wksZiel.Names("Print_Area").RefersToRange
Spalte = .Column + .Columns.Count - 1
sZelle = .Range("A1").Address & ":" & wksZiel.Cells(ZeileLetzte, Spalte).Address
End With
.PageSetup.PrintArea = sZelle
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "Fertig", vbInformation, "Z U S A M M E N F A S S U N G erstellen"
wksZiel.Range("Zeit_Aktualisierung") = Now
wksZiel.Activate
End If
Err.Clear
'Fehlerbehandlung
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr: " & .Number & vbLf & .Description
End Select
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
.StatusBar = False
End With
'Variablen aufräumen
'Dateiliste wieder entleeren
plCount = 0
Erase parrFiles
Set wbZiel = Nothing: Set wksZiel = Nothing: Set wksSteuer = Nothing
End Sub
Private Sub Daten_Auslesen(ByVal sFilename As String, ByVal ZeileZiel As Long)
Dim wbQuelle As Workbook
Dim sNameBlatt As String
'Datei mit Artikel-Kalkulation schreibgeschützt öffnen, ggf. inkl. Aktualisierung externer _
Verknüpfungen
Set wbQuelle = Application.Workbooks.Open(Filename:=sFilename, _
UpdateLinks:=wksSteuer.Range("Verknuepfungen") = "Ja", _
ReadOnly:=True)
If wksSteuer.Range("Berechnen") = "Ja" Then Application.Calculate
'Name der Quelldatei in Zielblatt eintragen und Hyperlink einfügen
With wksZiel
'Hyperlink zu Datei einfügen
.Hyperlinks.Add Anchor:=.Cells(ZeileZiel, 1), Address:=wbQuelle.FullName, _
ScreenTip:=wbQuelle.Name
.Cells(ZeileZiel, 1) = wbQuelle.Name
End With
'Zellen mit den Kalkulationsdaten gemäß Vorgaben im Blatt Steuerung auslesen und in _
Zielblatt eintragen
With wksSteuer
For Zeile = .Range("StartListe").Row + 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
sNameBlatt = .Cells(Zeile, 2).Text
sZelle = .Cells(Zeile, 3).Value
Spalte = .Cells(Zeile, 4).Value
If fncCheckSheet(varBlatt:=sNameBlatt, wb:=wbQuelle) = True Then
wksZiel.Cells(ZeileZiel, Spalte) = wbQuelle.Worksheets(sNameBlatt).Range(sZelle)
Else
MsgBox "Tabelle """ & sNameBlatt & """ ist in Datei """ & wbQuelle.Name & """ nicht _
vorhanden!", _
vbInformation + vbOKOnly, "Prozedur: Daten_Auslesen"
End If
Next
End With
wbQuelle.Close savechanges:=False
Set wbQuelle = Nothing
End Sub
Private Function fncCheckOeffnen(ByVal strFile As String) As Boolean
'Prüfen, ob Datei strFile geöffnet werden darf
'Hier werden Ausnahmen festgelegt für Excel-Dateien, die bei der Erstellung der _
Zusammenfassung nicht _
berücksichtig werden dürfen
Dim strDatei As String
fncCheckOeffnen = True
'Dateiname von Pfad\Dateiname abtrennen
strDatei = LCase(Mid(strFile, InStrRev(strFile, "\") + 1))
Select Case strDatei
Case LCase(ThisWorkbook.Name), "zusammenfassung.xls", "zusammenfassung.xlsm"
'Diese Dateien nicht in Zusammenfassung darstellen
fncCheckOeffnen = False
End Select
End Function
Public Function fncCheckSheet(ByVal varBlatt, Optional wb As Workbook) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
Dim objSheet As Object
On Error GoTo Fehler
If wb Is Nothing Then Set wb = ActiveWorkbook
fncCheckSheet = True
Set objSheet = wb.Sheets(varBlatt)
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
fncCheckSheet = False
End Select
End With
End Function