an Josef: Datensammlung

Hallo Josef (evtl. auch an andere Wissende),
danke nochmals für u.a. Makro. Kann man dieses insoweit aufbohren dass sich die Datensammlung nicht über einzelne Blätter einer Datei, sondern über alle Dateiene eines Verzeichnisses erstreckt.
Der Blattname in jder Datei ist der gleiche, demzufolge müßte in der neuen Datei der Dateiname der Ursprungsdatei abgelegt werden.
Für die anderen:
u.a. Sammelt daten aus mehreren Blättern einer Datei aus verschiedenen Zellen zusammen und bringt sie in einem neuen Blat Zeilenweise unter.
nochmals vioelen Dank
Walter
Sub Daten_sammeln() Dim wks As Worksheet Dim wksZ As Worksheet Dim strZelle As String Dim lastRow As Long Set wksZ = Sheets("Tabelle3") 'Blatt in dem die Daten gesammelt werden.(Name anpassen) strZelle = "F3" 'Zelle in der die daten stehen.(anpassen) lastRow = wksZ.Range("A65536").End(xlUp).Row + 1 For Each wks In ThisWorkbook.Worksheets If wks.Name <> wksZ.Name Then wksZ.Cells(lastRow, 1) = wks.Range(strZelle) wksZ.Cells(lastRow, 2) = wks.Name lastRow = lastRow + 1 End If Next End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Walter!
Kein Problem!
Bevor du das Makro ausführst, achte bitte auf die Kommentare in Code!
'Created By Chip Pearson and Pearson Software Consulting Services
'© Copyright 1997-2003 Charles H. Pearson
' http://www.cpearson.com/excel/BrowseFolder.htm
Option Explicit
'Using the Shell Controls Library
'
'First you need to set a reference to the "Microsoft Shell
'Controls And Automation" object library.
'In the VBA Editor, go to the Tools menu, choose References,
'and scroll down to this item and put a check next to it.
'
'Then, copy the following code to a standard code module:
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, _
InitialFolder)
If Not F Is Nothing Then
BrowseFolder = F.Items.Item.Path
End If
End Function
'ACHTUNG!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Vor Einsatz dieses Codes, muss unter >Extras>Verweise der Verweis
'auf "Microsoft Shell Controls And Automation" gesetzt werden!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Sub Daten_sammeln()
Dim fSearch As FileSearch
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksZ As Worksheet
Dim strZelle As String, strPath As String, strFile As String
Dim lastRow As Long
Dim iCnt As Integer
Set wksZ = Sheets("Tabelle3") '<<<Blatt in dem die Daten gesammelt werden.(Name anpassen)
strZelle = "F3" '<<<Zelle in der die daten stehen.(anpassen)
lastRow = wksZ.Range("A65536").End(xlUp).Row + 1
strPath = BrowseFolder("Verzeichnis wählen", "D:\") '<<<< Starverzeichnis angeben
If strPath = "" Then Exit Sub
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set fSearch = Application.FileSearch
With fSearch
.LookIn = strPath
.SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For iCnt = 1 To .FoundFiles.Count
Set wkb = Workbooks.Open(.FoundFiles(iCnt))
Set wks = wkb.Sheets("Tabelle1") '<<< anpassen
'Name des Tabellenblattes aus dem die Daten gelesen werden - anpassen
wksZ.Cells(lastRow, 1) = wks.Range(strZelle)
wksZ.Cells(lastRow, 2) = wks.Name
wksZ.Cells(lastRow, 3) = wks.Parent.Name
lastRow = lastRow + 1
wkb.Close , False
Next
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Gruß Sepp

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread