Office 2010: Sammelmakro-Probleme beim erfassen der Daten....

[Patrick1349]

Hallo!

ich habe folgende Frage: Ich habe es mit viel Hilfe geschafft ein Makro zu schreiben, was Daten aus anderen Dateien Sammelt und in einer Tabelle zusammenfast.

Jetzt habe ich aber folgende Probleme:

Erstens fängt er immer in Zeile 2 An Daten zu suchen.

Zweitens holt er sich Daten aus Dateien, die ich schon gelöscht habe.

Drittens: wirft er Daten aus, die nirgendwo stehen.

Vielleicht könnt Ihr mir weiterhelfen.

 

Hier mal der Code:

 

Sub Zusammenfassen()
Dim ArFiles()
Dim Q, Z
Dim R&, n&, nn&
Dim sQuellPfad$, sDir$
Dim wbGes As Workbook, wbQuelle As Workbook

sQuellPfad = "C:\Ringversuchsauswertungen\"
'Dateien Suchen
ChDrive sQuellPfad
ChDir sQuellPfad
sDir = Dir(sQuellPfad & "*.xls", vbNormal)
Do While sDir <> ""
    ReDim Preserve ArFiles(n)
    ArFiles(n) = sQuellPfad & sDir
    n = n + 1
    sDir = Dir$()
Loop

'alte Daten löschen
Set wbGes = ActiveWorkbook
With wbGes.Worksheets(1)
    If .UsedRange.Cells(.UsedRange.Rows.Count, 1).Row > 2 Then
        .Range(.Cells(3, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
    End If
End With
'Datei gefunden?
If n > 0 Then
    'Bremsen im Excel deaktivieren
    Events_ False
    'Quelle und Ziel.
    Q = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S") 'Quellzellen
    Z = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S") ' Zielspalten in Sammeldatei
    'Startzeile in Sammeltabelle
    R = 3
    For n = LBound(ArFiles) To UBound(ArFiles)
        'Datei öffnen
        Set wbQuelle = Workbooks.Open(ArFiles(n), ReadOnly:=True)
        'Datei Tabelle mit Index1
        With wbQuelle.Worksheets(1)
            'Schleife über Spalten im Array Q
            For nn = LBound(Q) To UBound(Q)
                With .Range(Q(nn) & 3, .Range(Q(nn) & .Rows.Count).End(xlUp))
                     wbGes.Worksheets(1).Range(Z(nn) & R).Resize(.Rows.Count).Value = .Value
                        End With
               
               
            Next nn
        End With
        'schließen ohne speichern
        wbQuelle.Close False
        'nächste freie Zeile
        With wbGes.Worksheets(1).UsedRange
            R = .Cells(.Rows.Count, 1).Row + 1
            If R < 3 Then R = 3
        End With
    Next n
    'Bremsen im Excel wieder aktivieren
    Events_ True
Else
    MsgBox "keine Datei gefunden!"
End If

wbGes.Save

MsgBox "Fertig."
       
End Sub

Sub Events_(booOn)
Static lngCalc As Long
With Application
    If booOn = False Then lngCalc = .Calculation
    .Calculation = IIf(booOn, lngCalc, xlCalculationManual)
    .ScreenUpdating = booOn
    .EnableEvents = booOn
    .DisplayAlerts = booOn
End With
End Sub