Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
976to980
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
976to980
976to980
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Werte aus verschiedenen Dateien in 1 D. kopieren

Werte aus verschiedenen Dateien in 1 D. kopieren
12.05.2008 14:51:23
vux
Hallo,
ich bräuchte eure Expertise um folgenden Vorgang automatisch abzubilden:
Ich habe einen Ordner "Files" in dem mehere gleich aufgebaute Dateien liegen, "Source1", "Source2"...
In jeder "Source Datei" gibt es das Sheet "Database".
Es gibt eine Ebene drüber, die Datei "Aggregation", wo es auch das Sheet "Database" gibt.
Nun sollen alle Zeilen (bis auf Header, also Zeile 1), der "Source Dateien" ausgelesen werden und untereinander in das Database Sheet der "Aggregation Datei" kopiert werden.
Makro wird über Button in Aggregation Database Sheet aufgerufen.
Pseudo Code müssto so aussehen:
1) For all "Source-Files" in "Files Folder"
- Unhide Sheet "Database" (in Source File)
2) Loop through "Source File Database sheet" (until last filled row)
- Copy paste row from Source to Aggregation
- Hide Sheet "Database" (in Source File)
- Close Source File
Also, wenn jemand diese Befehle drauf hat, würde mich Hilfe sehr freuen!
Danke
ps.
Anstatt der 2) Schleife könnte man auch probieren dynamisch eine Range zu erstellen, um auf einmal alle Werte zu kopieren. Das wäre viel schneller, da man nur einmal copy paste pro file machen müsste.
Ich mache das immer mit (man muss aber aufpassen, dass aus den "Source Files" der Header nicht mit kopiert wird)
OFFSET(Sheet1!$A$1;;;COUNTA(Sheet1!$A:$A);COUNTA(Sheet1!$1:$1))
COUNTA(Sheet1!$A:$A): dynamische Erfassung der "Y-Achse"
COUNTA(Sheet1!$1:$1): dynamische Erfassung der "X-Achse", diese könnte man in diesem Fall auch fix machen, da die Range immer gleich breit ist (Spaltenzahl, konstant)

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte aus verschiedenen Dateien in 1 D. kopieren
12.05.2008 19:23:15
Josef
Hallo ?
Anrede?
Frage?
Gruß?
Ungetestet. Gehört in ein Modul der Datei "Aggregation".
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub CopyData()
Dim objTarget As Worksheet, objWB As Workbook
Dim lngR As Long, lngC As Long, lngL As Long
Dim tmp, res As Long, strPath As String, n As Long, a As Variant

On Error GoTo ErrExit
GMS

Set objTarget = ThisWorkbook.Sheets("Database")

strPath = ThisWorkbook.Path & "\Files\"

res = FileSearchFSO(tmp, strPath, "*.xls*", False)

lngC = 12 'Anzahl der zu kopierenden Spalten - Anpassen!

If res <> 0 Then
    For n = 0 To UBound(tmp)
        Set objWB = Workbooks.Open(tmp(n))
        With objWB.Sheets("Database")
            a = .Range(.Cells(2, 1), .Cells(Application.Max(2, .Cells(1, 1).End(xlUp).Row), lngC))
        End With
        objWB.Close False
        With objTarget
            lngL = Application.Max(2, .Cells(1, 1).End(xlUp).Row + 1)
            .Range(.Cells(lngL, 1), .Cells(lngL + UBound(a, 1), lngC)) = a
        End With
    Next
End If

ErrExit:
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
End If

GMS True
Set objWB = Nothing
Set objTarget = Nothing
End Sub

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


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    End If
Next

If SubFolders Then
    For Each mfsoSubFolder In mfsoFolder.SubFolders
        FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
    Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub


Gruß Sepp



Anzeige
Fehler!
12.05.2008 22:54:00
Josef
Hallo nochmal,
da war ein Fehler im Code.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub CopyData()
Dim objTarget As Worksheet, objWB As Workbook
Dim lngR As Long, lngC As Long, lngL As Long
Dim tmp, res As Long, strPath As String, n As Long, a As Variant

On Error GoTo ErrExit
GMS

Set objTarget = ThisWorkbook.Sheets("Database")

strPath = ThisWorkbook.Path & "\Files\"

res = FileSearchFSO(tmp, strPath, "*.xls*", False)

lngC = 12 'Anzahl der zu kopierenden Spalten - Anpassen!

If res <> 0 Then
    For n = 0 To UBound(tmp)
        Set objWB = Workbooks.Open(tmp(n))
        With objWB.Sheets("Database")
            a = .Range(.Cells(2, 1), .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row), lngC))
        End With
        objWB.Close False
        With objTarget
            lngL = Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
            .Range(.Cells(lngL, 1), .Cells(lngL + UBound(a, 1), lngC)) = a
        End With
    Next
End If

ErrExit:
If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
End If

GMS True
Set objWB = Nothing
Set objTarget = Nothing
End Sub

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


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    End If
Next

If SubFolders Then
    For Each mfsoSubFolder In mfsoFolder.SubFolders
        FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
    Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub


Gruß Sepp



Anzeige
AW: Fehler!
13.05.2008 16:09:08
vux
Hi!
das Skript macht einen sehr eleganten Eindruck, leider ist einiges nicht ganz intuitiv nachvollziehbar für einen Anfänger.
Wäre es möglich dass du Kommentare hinzufügst, sodass klar wir, was die einzelnen Funktionen machen - das würde anderen Usern die mal auf dein Skript stossen, auch sehr weiterhelfen.
Wäre klasse
Danke

AW: Werte aus verschiedenen Dateien in 1 D. kopier
12.05.2008 21:38:00
fcs
Hallo vux,
ich hab auch mal in meinem Archiv gestöbert und eine Lösung etwas für dich angepasst.
Ablauf ist ähnlich wie bei Josef; allerdings werden die Zellen von der Quelle ins Ziel kopiert und nicht via Array übertragen.
Ich hab in Excel97 Probleme mit einigen Formaten (Datum, Währung) wenn ich nicht die Kopierfunktionen benutze. Dann geraten manchmal US-Formate in die Zellen.
Per Parameter kannst du einstellen, ob du nur die Werte oder Alles (Werte, Formate, Formeln) kopieren willst.
Gruß
Franz

'Erstellt: fcs 2006-08-15, modifiziert 2008-05-12
'Programm: Excel 97
Sub aatest()
Dim strVerzeichnis As String, wksSteuer As Worksheet, varListe As Variant
Dim lngZeile As Long, intI As Integer
'  Set wksSteuer = ThisWorkbook.Worksheets("Steuerung")
strVerzeichnis = fncVerzeichnis(strFilter:="Exceldateien(*.xls), *.xls")
If strVerzeichnis  "" Then
With ThisWorkbook.Worksheets("Database")
'Letzte Spalte in Zieltabelle
intI = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Import starten
If fncZusammenfuehren_Daten(varDateiListe:=varListe, _
strVerzeichnis:=strVerzeichnis, _
strFilter:="*.xls", _
varQuelleName:="Database", _
lngZeile1:=2, intSpalten:=intI, _
wksZiel:=ThisWorkbook.Worksheets("Database"), _
bolNurWerte:=True) = True Then
'      With wksSteuer
'Liste der Quelldateien löschen
'.Range(.Cells(4, 1), .Cells(4, 1).End(xlDown)).ClearContents
'Liste der Quelldateien schreiben
'.Cells(2, 1).Value = strVerzeichnis
'lngZeile = 4
'For intI = LBound(varListe) To UBound(varListe)
'  .Cells(lngZeile, 1).Value = varListe(intI)
'  lngZeile = lngZeile + 1
'Next
'      End With
Else
'do nothing
End If
End If
End Sub
Function fncZusammenfuehren_Daten(varDateiListe As Variant, strVerzeichnis As String, _
varQuelleName As Variant, lngZeile1 As Long, intSpalten As Integer, _
wksZiel As Worksheet, Optional strFilter As String = "*.xls", _
Optional bolNurWerte As Boolean = True) As Boolean
'Kopiert die Daten aus der Quelltabelle der Dateien im Verzeichnis in die Zieltabelle
'Erläuterung Parameter:
'varDateiListe  = Array-Variable in der die Quell-Dateinamen gespeichert werden
'strVerzeichnis = Verzeichnis in dem die Quelldateien gesucht werdne sollen
'varQuelleName  = Name oder Index-Nummer Quell-Tabellenblatts
'lngZeile1      = 1. Datenzeile
'intSpalten     = Anzahl Spalten
'wksZiel        = Zieltabellenblatt
'strFilter      = Dateifilter für die Quelldateien
'bolNurWerte = True: nur Werte werden kopier, False: Alles wird kopiert
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim lngLetzteZeile As Long, lngZeileDaten As Long, lngNr As Long
Dim strDatei As String
Dim arrDateien() As String, intCount As Integer
Dim strMsg As String, intFehler As Integer
On Error GoTo Fehler
Application.ScreenUpdating = False
'Exceldateien im Verzeichnis Öffnen
strDatei = Dir(strVerzeichnis & Application.PathSeparator & strFilter)
Do Until strDatei = ""
lngNr = lngNr + 1
Application.StatusBar = "Die " & lngNr - 1 _
& ". Datei wird bearbeitet, Dateiname: " & strDatei
'Quelldatei schreibgeschützt öffnen
strDatei = strVerzeichnis & Application.PathSeparator & strDatei
Set wbQuelle = Workbooks.Open(FileName:=strDatei, ReadOnly:=True)
intFehler = 1
Set wksQuelle = wbQuelle.Worksheets(varQuelleName)
'Nächste Einfügezeile in Zieltabelle ermitteln
With wksZiel
lngZeileDaten = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With wksQuelle
If lngZeileDaten + .UsedRange.Rows.Count > wksZiel.Rows.Count Then
MsgBox "Nicht genug freie Zeilen zum Übernehmen der nächsten Daten!"
GoTo Beenden
End If
'Dateiname in Importliste eintragen
intCount = intCount + 1
ReDim Preserve arrDateien(1 To intCount)
arrDateien(intCount) = wbQuelle.Name
'Datenbereich ab intZeile1 kopieren
.Visible = xlSheetVisible
lngLetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile Spalte A
If bolNurWerte = True Then
.Range(.Cells(lngZeile1, 1), .Cells(lngLetzteZeile, intSpalten)).Copy
wksZiel.Cells(lngZeileDaten, 1).PasteSpecial Paste:=xlPasteValues
Else
.Range(.Cells(lngZeile1, 1), .Cells(lngLetzteZeile, intSpalten)).Copy _
Destination:=wksZiel.Cells(lngZeileDaten, 1)
End If
Application.CutCopyMode = False
End With
ResumeFehler1:
'Quelldatei ohne speichern schliessen
wbQuelle.Close Savechanges:=False
'nächste Datei suchen
strDatei = Dir
Loop
'Quelldateiliste zurückschreiben
varDateiListe = arrDateien
fncZusammenfuehren_Daten = True
GoTo Beenden
Fehler:
strMsg = "Fehler Nummer: " & Err.Number & vbLf & Err.Description
Select Case intFehler
Case 1
strMsg = strMsg & vbLf & vbLf & "Quelltabelle " & varQuelleName _
& " ist in der Datei " & wbQuelle.Name & " nicht vorhanden!"
MsgBox strMsg
intFehler = 0
Resume ResumeFehler1:
Case Else
MsgBox strMsg
End Select
fncZusammenfuehren_Daten = False
Beenden:
Set wbQuelle = Nothing: Set wksQuelle = Nothing
ReDim arrDateien(0)
Application.StatusBar = False
Application.ScreenUpdating = True
End Function
Function fncVerzeichnis(Optional strFilter As String = "Alle(*.*), *.*") As String
'Auswahl einer Datei zur Auswahl eines Verzeichnisses
Dim varAuswahl As Variant
varAuswahl = Application.GetOpenFilename(FileFilter:=strFilter, _
Title:="Bitte eine Datei im gewünschten Verzeichnis selektieren und 'Öffnen'")
If varAuswahl  False Then
'Dateiname abtrennen
Do Until Right(varAuswahl, 1) = Application.PathSeparator
varAuswahl = Left(varAuswahl, Len(varAuswahl) - 1)
Loop
fncVerzeichnis = Left(varAuswahl, Len(varAuswahl) - 1)
End If
End Function


Anzeige
AW: Werte aus verschiedenen Dateien in 1 D. kopieren
13.05.2008 09:39:00
vux
Hallo ihr beiden!
Vielen herzlichen Dank für die Mühen, ich komme jetzt erst dazu mir die Sachen anzuschauen - hoffe dass ich da durchsteige.
Besten Dank!

Es funktioniert, angepasster Code hier
14.05.2008 14:18:00
vux
Hallo!
vielen vielen Dank für euren Code - habs zum Laufen bekommen - von alleine kommt man da nie so schnell drauf.
Hier der Code für andere User, etwas auskommentiert und mit sprecherenden Variablennamen.
'Copys database values from source files into Consolidation tool database sheet
Sub CopyData()
Dim objTarget As Worksheet, objWB As Workbook
Dim NumberColumns As Long, LastRow As Long
Dim SourceRange As Variant
Dim SourceFiles, NumberSourceFiles As Long, strPath As String, n As Long
On Error GoTo ErrExit
'GMS
Set objTarget = ThisWorkbook.Sheets("Database")
'Path to source files folder
strPath = ThisWorkbook.Path & "\Files\"
'Get number of source files in Files folder
NumberSourceFiles = FileSearchFSO(SourceFiles, strPath, "*.xls*", False)
'Number of colmns to copy
NumberColumns = 45
If NumberSourceFiles 0 Then
'Loop number though all files in Files folder (stored in SourceFiles array)
For n = 0 To UBound(SourceFiles)
Set objWB = Workbooks.Open(SourceFiles(n))
'Open Database sheet in source file
With objWB.Sheets("Database")
'Dynamic selection of range of values in source database sheet
SourceRange = .Range(.Cells(2, 1), .Cells(Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row), NumberColumns))
End With
objWB.Close False
With objTarget
'Dynamic finding of last entry in traget database sheet
LastRow = Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
'Assigne selected range to target range (copy paste source data into target database sheet)
.Range(.Cells(LastRow, 1), .Cells(LastRow + (UBound(SourceRange, 1) - 1), NumberColumns)) = SourceRange
End With
Next
End If
ErrExit:
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
End If
'GMS True
Set objWB = Nothing
Set objTarget = Nothing
'Message box to show successful data transfer completion
MsgBox "Data transfer from module workbooks successful: " & vbLf & NumberSourceFiles & " modules copied", vbInformation, "Successful completion"
End Sub


'Returns number of excel files in Source Files folder


Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Set mobjFSO = CreateObject("Scripting.FileSystemObject")
'Set mfsoFolder to Files (source) folder
Set mfsoFolder = mobjFSO.GetFolder(InitialPath)
On Error Resume Next
'Loop through each file in Files (source) folder
For Each mfsoFile In mfsoFolder.Files
If Not mfsoFile Is Nothing Then
'check if mfsoFile is xls file
If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
'Add current file string to Files Array
Files(UBound(Files)) = mfsoFile
End If
End If
Next
If SubFolders Then
For Each mfsoSubFolder In mfsoFolder.SubFolders
FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
Next
End If
'Return number of (source) files in folder Files
If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function


Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige