12.07.2017, 14:54
(12.07.2017, 14:43)Jockel schrieb: Hallo, wenn das so ist, werden die Tabellenblätter fortgeschrieben oder immer wieder neu beschrieben..? Die Daten wären dann weg, oder sie müssten per VBA ins andere Blatt
Jeden tag in ein neues Blanco. dort noch ein mal bearbeitet und dann automatisiert via VBA und dritter Datei abgerufen.
Code:
Sub Lese()
Dim intBereich As Integer
Dim intZeile As Integer
Dim intSpalte As Integer
Dim strDatei As String
Dim intAnzVerz As Integer
Dim intAktVerz As Integer
Dim intAktBlatt As Integer
Dim intAktZeile As Integer
Dim intAktSpalte As Integer
Dim intSpDatum As Integer
Dim intSpBlatt As Integer
Dim intSpDatei As Integer
Dim intSpVerz As Integer
Dim strVerz As String
Dim strVerzA() As String
Dim varDatum As Variant
Dim varKopie As Variant
Dim varRngKopie As Variant
Dim bolLeer As Boolean
Dim rngAusgabe As Range
Dim wbLesen As Workbook
Dim wsLesen As Worksheet
Const intMaxVerz As Integer = 30
Const intMaxblatt As Integer = 2
Const strTeilDatei As String = ".xlsx"
Const strRngDatum As String = "C2"
Const strRngKopie As String = "B3:J55"
Const bolZeigVerz As Boolean = False
Const bolZeigDatei As Boolean = False
Const bolZeigBlatt As Boolean = False
Const bolZeigLeer As Boolean = True
Application.ScreenUpdating = False
'----------------------------------------------------
' Spalten für Verzeichnis, Datei und Blatt einrichten
'----------------------------------------------------
intSpDatum = 0
intSpBlatt = 0
intSpDatei = 0
intSpVerz = 0
If bolZeigBlatt Then
intSpDatum = intSpDatum + 1
End If
If bolZeigDatei Then
intSpDatum = intSpDatum + 1
intSpBlatt = intSpBlatt + 1
End If
If bolZeigVerz Then
intSpDatum = intSpDatum + 1
intSpBlatt = intSpBlatt + 1
intSpDatei = intSpDatei + 1
End If
varRngKopie = Split(strRngKopie)
'----------------------------------------------------
' Verzeichniseinlesen und Variablen initialisieren
'----------------------------------------------------
ReDim strVerzA(intMaxVerz)
intAktVerz = 1
intAnzVerz = 1
intAktZeile = 0
strVerzA(intAnzVerz) = ThisWorkbook.Names("Verzeichnis").RefersToRange
Set rngAusgabe = ThisWorkbook.Worksheets("Füllung").Cells(3, 1)
'Set rngAusgabe = ThisWorkbook.Names("Ausfüllen").RefersToRange
'----------------------------------------------------
' Schleife über Verzeichnisse
'----------------------------------------------------
While intAktVerz <= intAktVerz And intAktVerz <= intMaxVerz
strVerz = strVerzA(intAktVerz)
strDatei = Dir(strVerz, vbDirectory)
'----------------------------------------------------
' Schleife über Dateien im Verzeichnis
'----------------------------------------------------
While strDatei <> ""
If (GetAttr(strVerz & strDatei) And vbDirectory) = vbDirectory Then
If strDatei <> "." And strDatei <> ".." And strDatei <> "" And intAnzVerz < intMaxVerz Then
intAnzVerz = intAnzVerz + 1
strVerzA(intAnzVerz) = strVerz & strDatei & "\"
End If
Else
If InStr(strDatei, strTeilDatei) > 0 And strDatei <> ThisWorkbook.Name Then
intAktBlatt = 0
Set wbLesen = Workbooks.Open(Filename:=strVerz & strDatei, ReadOnly:=True)
For Each wsLesen In wbLesen.Worksheets
intAktBlatt = intAktBlatt + 1
If intAktBlatt <= intMaxblatt Then
varDatum = wsLesen.Range(strRngDatum)
For intBereich = 0 To UBound(varRngKopie)
varKopie = wsLesen.Range(varRngKopie(intBereich)).Value
For intZeile = 1 To UBound(varKopie, 1)
'----------------------------------------------------
' Prüfen ob Werte leer
'----------------------------------------------------
If bolZeigLeer Then
bolLeer = False
Else
bolLeer = True
For intSpalte = 1 To UBound(varKopie, 2)
If varKopie(intZeile, intSpalte) <> "" Then
bolLeer = False
End If
Next intSpalte
End If
'----------------------------------------------------
' Schreiben wenn nicht leer
'----------------------------------------------------
If Not bolLeer Then
For intSpalte = 1 To UBound(varKopie, 2)
rngAusgabe.Offset(intAktZeile, intSpalte + intSpDatum).Value = varKopie(intZeile, intSpalte)
Next intSpalte
rngAusgabe.Offset(intAktZeile, intSpVerz).Value = strVerz
rngAusgabe.Offset(intAktZeile, intSpDatei).Value = strDatei
rngAusgabe.Offset(intAktZeile, intSpBlatt).Value = wsLesen.Name
rngAusgabe.Offset(intAktZeile, intSpDatum).Value = varDatum
intAktZeile = intAktZeile + 1
End If
Next intZeile
Next intBereich
End If
Next wsLesen
wbLesen.Close savechanges:=False
End If
End If
strDatei = Dir()
Wend
intAktVerz = intAktVerz + 1
Wend
Application.ScreenUpdating = True
End SubMit der Script rufe ich eben ab.
ggf. kann man diese anpassen, dass sie nur Neuerungen listet oder das was abgerufen wird an vorhandene liste abgleicht und nur Neuerungen anfügt.
Danke und Gruß
