AW: Inhalt von Datei übertragen
20.09.2007 17:03:14
Datei
Hallo Thomas,
hier eine Subroutine, die einen entsprechendne Datum von-bis Filter in einer externen Datei setzt und die gefilterten Daten in die Zeltabelle kopiert. Eine Prüfung, ob Quelldatei schon geöffnet, hab ich nicht drin; die muss du dir woanders besorgen.
Gruß
Franz
Sub Test()
Dim gdatum3 As Date, gdatum4 As Date, strFilter$, wksZiel As Worksheet
gdatum3 = DateSerial(1995, 1, 1)
gdatum4 = DateSerial(1998, 1, 1)
strFilter = "A4" 'Einfügezelle für gefilterte Daten
Set wksZiel = Worksheets("Tabelle4")
'ggf. vorhandene Daten Löschen
With wksZiel
If .Range(strFilter).End(xlDown).Row .Rows.Count Then
.Range(.Range(strFilter), .Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
End With
Call GefilterteDatenHolen(Datum1:=gdatum3, Datum2:=gdatum4, SpalteDatum:=3, _
strwbZiel:=ActiveWorkbook.Name, varTabZiel:=wksZiel.Name, strZelleZiel:=strFilter, _
strwbQuelle:="C:\Lokale Daten\Test\Test.xls", varTabQuelle:="Tabelle1", _
strAdresseFilter:="A1")
End Sub
Sub GefilterteDatenHolen(Datum1 As Date, Datum2 As Date, SpalteDatum%, strwbZiel$, _
varTabZiel, strZelleZiel$, strwbQuelle$, varTabQuelle, strAdresseFilter)
'Nach Datumsbereich gefilterte Daten aus anderer geschlossenener Datei holen
'SpalteDatum: Ist die Nummer der Spalte in der das zu filternde Datum in der Quelle steht
'strwbZiel: Name der Quell-Datei (Datei muss geöffnet sein)
'strZelleZiel: Zelladresse ab der die Daten in der Zieltabelle eingefügt werden
'strwbQuelle: Name inkl.Pfad der Quell-Datei (Datei muss geschlossen sein)
'strAdresseFilter: Addresse der Linken oberen Zelle des Autofilterbereichs _
(1. Zelle links mit Dropdown-Auswahl)
Dim wbQuelle As Workbook, wbZiel As Workbook
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim FehlerNr As Integer, Bereich As Range, FehlerText$
'Prüfen ob Datei vorhanden
FehlerNr = 1
If Dir(strwbQuelle) = "" Then
MsgBox "Datei: " & strDatei & " nicht gefunden!"
GoTo Beenden
End If
On Error GoTo Fehler
FehlerNr = 2
Set wbZiel = Workbooks(strwbZiel)
Set wksZiel = wbZiel.Worksheets(varTabZiel)
FehlerNr = 3
Set wbQuelle = Workbooks.Open(Filename:=strwbQuelle, ReadOnly:=True)
Set wksQuelle = wbQuelle.Worksheets(varTabQuelle)
With wksQuelle
FehlerNr = 4
If .AutoFilterMode = True Then
If .Cells.SpecialCells(xlCellTypeVisible).Count .Cells.Count Then
.ShowAllData
End If
'vorhandenen Autofilterbereich zuweisen
Set Bereich = .AutoFilter.Range
Else
'Autofilterbereich festlegen
Set Bereich = .Range(.Range(strAdresseFilter), _
.Cells.SpecialCells(xlCellTypeLastCell))
Bereich.AutoFilter
End If
Bereich.AutoFilter Field:=SpalteDatum - Bereich.Column + 1, _
Criteria1:=">=" & CDbl(Datum1), Operator:=xlAnd, _
Criteria2:="