VBA Vergleichen und anfügen

[tw3aker]

Hallo miteinander,

ich habe ein Problem. vor einiger Zeit habe ich dank der Hilfe einiger Mitglieder eine Abrufen Datei erstellen können, welche meinen Ordner durchsucht und alle Excel Dateien deren werte auflistet.

Jetzt ist es so, da jeden Tag eine neue Datei dazukommt, bricht jetzt die VBA Script ab. (ggf. jetzt einfach zu viel zum kopieren oä.)
Vermute ich.
 
Das ist der Entstandene Code dafür.

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 Sub

Jetzt habe ich mir überlegt, da ich mit dem abrufen Probleme habe, jedes Jahr einen neuen Ordner anzulegen und dann nur noch nach Jahr abzurufen.
 
Wenn dann abgerufen ist, alle Daten zusammenführen.
 
Kann man das irgendwie sinnvoll lösen?
 
Hat jemand Tipps?
 
Die Daten müssten bei der Zusammenführung kontrolliert und ersetzt bzw. das was noch nicht vorhanden ist angefügt werden.

Ich hoffe ihr könnt mir helfen.

Viele liebe Grüße und schon mal vielen Dank vorab

[Rabe]

Hi,

importierst Du echt jeden Tag alle vorhergehenden und die eine neue Datei? Ist das sinnvoll?

Du könntest doch alle importierten Dateien nach dem Import in ein Archiv-Verzeichnis verschieben lassen und dann nur noch die eine neue Datei importieren, das ist auch insgesamt viel schneller.

[snb]

Zu aufwändige Code für eine einfache Aufgabe.

[tw3aker]

Hallo Ralf,

aktuell ja. Das ist eine gute Idee. Wie könnte ich das so anpassen, dass das klappt??

SNB was empfiehlst du denn?
Ich kann es leider nicht gut genug um es zu vereinfachen bzw um es stabiler zu machen.

Danke und lieben Gruß

[tw3aker]

Hallo, hat keiner einen Tip?

Lieben Gruß

[schauan]

Hallöchen,

hast Du denn den Tipp von Ralf mal ausprobiert?

Per Code könntest Du das im Prinzip so umsetzen:

Code:

Dim FSO as FileSystemObject
FSO.MoveFile OldPath & OldName, NewPath & OldName

Du müsstest noch einen Verweis auf das Windows Scripting setzen.

Eine einfache Alternative wäre auch das Umbenennen:

Code:

Name OldName As NewName

Wenn Du da aus der Exceldatei eine Excel.Sik machst

Code:

Name OldName As OldName & ".sik"

werden die eventuell auch nicht mehr eingelesen.