Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
876to880
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
876to880
876to880
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

xls-Dateien: Bereiche ermitteln und übertragen

xls-Dateien: Bereiche ermitteln und übertragen
13.06.2007 23:28:39
Peter
Guten Abend
Ca. vor einer Woche hat mir Matthias G. auf eine Anfrage im Forum hin nachfolgenden Code geschrieben, den ich noch etwas modifiziert habe. Dieser Makro (in der persönlichen Makrovorlage abgelegt) bewirkt folgendes:
1)
im aktiven Worksheet der aktiven Datei (sagen wir sie heisse „Aktiv.xls“) werden sämtliche xls-Dateinamen des aktuellen Pfades aufgeführt (ausser der xls-Datei, die gerade aktiv ist).
2)
die entsprechenden Dateien werden eine nach der anderen geöffnet und aus der Tabelle „GLOBAL“ in allen aufgelisteten Dateien enthalten wird abgefragt, welches der letzte Eintrag in Spalte B ist. Dieser Wert wird in ein Worksheet namens „Daten“ der Datei „Aktiv.xls“ eingetragen.
Das funktioniert so tadellos. Nun, die ursprüngliche Absicht war – und das war wohl nicht genügend klar beschrieben – dass bei allen aufgelisteten Dateien im Worksheet „GLOBAL“ ermittelt wird, in welcher Zelle der Spalte B der letzte Eintrag ist und dass dann alle Zeilen bis dorthin kopiert werden und in die Datei „Aktiv.xls“ – Worksheet „GLOBAL“ übernommen werden. Angenommen, es wären nur 2 Dateien aufgelistet, und in der ersten wären in der Spalte B Einträge bis Zeile 53, würde der Bereich 1:53 in die Datei Aktiv.xls, Worksheet Daten reinkopiert, ebenfalls in den Bereich 1:53. Wenn nun in der zweiten Datei in Spalte B Einträge bis Zeile 20 enthalten sind, würden diese kopiert und in die Datei Aktiv.xls, Worksheet Daten“ in den Bereich 54:73 hineinkopiert.
Kann mir jemand sagen, wie ich die Funktion, vgl. ganz unten so abändere, dass nicht nur der Inhalt der letzte Zeile von Spalte ermittelt und übertragen (wird, sondern der ganze Bereich?
Wäre super!
Danke, Peter

Sub Dateien()
Const TabName = "GLOBAL" 'Blattname der Dateien
Const TabZiel = "Daten" ' Blatt in dem die Daten ankommen sollen
Dim strVerz As String
Dim strDatei As String
Dim lngZ As Long, i As Long, lr As Long
Dim WBAktiv As Workbook
Dim ShTab As Worksheet
Dim WB As Workbook
Set WBAktiv = ActiveWorkbook
Set ShTab = ActiveSheet
strVerz = ActiveWorkbook.Path & "\" 'Backslash am Ende nicht vergessen!
ShTab.Columns(1).ClearContents
Application.ScreenUpdating = False
'Verzeichnis auslesen
strDatei = Dir(strVerz & "*.xls")
'Debug.Print strDatei
Do Until strDatei = ""
If UCase(strVerz & strDatei)  UCase(ActiveWorkbook.FullName) Then
lngZ = lngZ + 1
ShTab.Cells(lngZ, 1) = strDatei
End If
strDatei = Dir()
Loop
'Dateien nacheinander öffnen
For i = 1 To lngZ
Set WB = Workbooks.Open(Filename:=strVerz & ShTab.Cells(i, 1))
'letzte beschriebene Spalte ermitteln:
lr = LastRow(WB.Worksheets(TabName), 1)
'Wenn Spalte nicht leer dann...
If lr > 0 Then
'...Wert in Blatt [TabZiel] eintragen
WBAktiv.Sheets(TabZiel).Cells(i, 1) = WB.Worksheets(TabName).Cells(lr, 2)
End If
'Mappe (ohne speichern) schließen
WB.Close False
Next i
Application.ScreenUpdating = True
End Sub


'ermittelt letzte beschriebene Zelle von [Sh] in Spalte [col]


Function LastRow(sh As Worksheet, col As Integer) As Long
Dim rng As Range
Set rng = sh.Cells(sh.Rows.Count, col)
If rng.Value = "" Then
Set rng = rng.End(xlUp)
If rng = "" Then LastRow = 0: Exit Function
End If
LastRow = rng.Row
End Function


1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: xls-Dateien: Bereiche ermitteln und übertragen
14.06.2007 14:44:00
Peter
Hallo
Ich habe nun die Lösung gefunden:

Sub Dateien()
'Const TabName = "GLOBAL" 'Blattname der Dateien
Const TabZiel = "Daten" ' Blatt in dem die Daten ankommen sollen
Dim TabName As String
Dim strVerz As String
Dim strDatei As String
Dim lngZ As Long, i As Long, lr As Long, lrZiel As Long, xSpalte As Long
Dim WBAktiv As Workbook
Dim ShTab As Worksheet
Dim WB As Workbook
Set WBAktiv = ActiveWorkbook
Set ShTab = WBAktiv.Sheets("Dateien")
TabName = Range("CTab").Value
xSpalte = Range("xSpalteNr").Value
strVerz = ActiveWorkbook.Path & "\" 'Backslash am Ende nicht vergessen!
ShTab.Columns(1).ClearContents
WBAktiv.Sheets(TabZiel).Cells.ClearContents
Application.ScreenUpdating = False
'Verzeichnis auslesen
strDatei = Dir(strVerz & "*.xls")
'Debug.Print strDatei
Do Until strDatei = ""
If UCase(strVerz & strDatei)  UCase(ActiveWorkbook.FullName) Then
lngZ = lngZ + 1
ShTab.Cells(lngZ, 1) = strDatei
End If
strDatei = Dir()
Loop
'Dateien nacheinander öffnen und Daten übertragen
For i = 1 To lngZ
Set WB = Workbooks.Open(Filename:=strVerz & ShTab.Cells(i, 1))
lr = WB.Worksheets(TabName).Cells(Rows.Count, xSpalte).End(xlUp).Row   'Spalte wird über  _
Dropdownmenu in Worksheet abgefragt
'Wenn Spalte nicht leer dann...
If lr > 0 Then
'...Wert in Blatt [TabZiel] eintragen
lrZiel = WBAktiv.Sheets(TabZiel).Cells(Rows.Count, xSpalte).End(xlUp).Row + 1   'Spalte  _
wird über Dropdownmenu in Worksheet abgefragt
Select Case i
Case 1
' WB.Worksheets(TabName).Rows("1:" & lr).Copy Destination:=WBAktiv.Sheets(TabZiel).Rows( _
lrZiel)
'mit voriger Zeile würde der ganze Inhalt übertragen
WB.Worksheets(TabName).Rows("1:" & lr).Copy
With WBAktiv.Sheets(TabZiel).Rows(lrZiel - 1)
.PasteSpecial Paste:=xlValues   'Werte
'.PasteSpecial Paste:=xlFormats      ' Formate
End With
Application.CutCopyMode = False
Case Else
' WB.Worksheets(TabName).Rows("2:" & lr).Copy Destination:=WBAktiv.Sheets(TabZiel).Rows( _
lrZiel)
'mit voriger Zeile würde der ganze Inhalt übertragen
WB.Worksheets(TabName).Rows("2:" & lr).Copy
With WBAktiv.Sheets(TabZiel).Rows(lrZiel)
.PasteSpecial Paste:=xlValues   'Werte
'.PasteSpecial Paste:=xlFormats      ' Formate
End With
Application.CutCopyMode = False
End Select
End If
'Mappe (ohne speichern) schließen
WB.Close False
Next i
Application.ScreenUpdating = True
End Sub


Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige