AW: Dateien aus Ordnern auslesen Programmüberarbei
23.07.2007 01:25:00
fcs
Hallo Thomas,
ich hab mir deine Datei einmal vorgenommen.
Folgende Punkte könnte man für Verbesserungen in Betracht ziehen:
1 Beim Erzeugen der Dateiliste nur die Dateien in die Liste aufnehmen, deren Erstelldatum/Zeitpunkt nach dem letzten Zeitpunkt der Aktualisierung der Projektübersicht liegt.
2 Die Übertragung der neuen Dokumentdaten in die Projektübersicht kann man durch ein entsprechend komplexeres Makro für den Anwender einfacher gestalten. Einen ersten Anlauf findest du im Anschluss.
3 Die Verfeinerung meiner Variante wäre, dass das Makro den korrekten Ordner zum Einfügen der jeweiligen neuen Dokumentdaten automatisch findet. Dazu müßte man aber die Datenstrukturen etwas besser kennen und wissen wo unter welchen Randbedingungen (Sortierung, bei Revisionen das neuere ober-/unterhalb des vorhandenen Eintrags usw.) neue Dokumentdaten in die Ordner eingefügt werden sollen.
Nachfolgend mein erster Ansatz zu Nr. 2.
Folgende Änderungen ergeben sich:
1.: In der Projektübersicht müssen die für das Einfügen der neuen Daten erforderlichen Leerzeilen nicht mehr vom Anwender erzeugt werden. Es muss "nur" noch die Zelle/Zeile selektierte werden, vor der die neuen Einträge eingefügt werden sollen.
2.: Im Blatt "Ordner Auslesen" muss nicht mehr exakt der Zellenbereich (Spalten A bis G) markiert werden, der übertragen werden soll. Es reicht aus, wenn die Zeilen komplett markiert werden oder einfach nur ein Zellbereich, der die gewünschten Zeilen "berührt".
3.: Einige Prüfungen sind eingebaut, die Übertragungsfehler veringern.
Vor dem Start des Einfügens muss nochmals bestätigt werden, ob die Einfügezeile korrekt ist.
Der Speicherort wird bei jedem Datensatz auf Übereinstimmung geprüft .
4.: Der Inhalt der Datensätze, die in die Projektübersicht übertragen sind wird im Blatt "Ordner Auslesen"
gelöscht. Verhindert Doppelübertragungen.
Ich hoffe die Kommentare im Code sind ausreichend, damit du die Aktionen nachvollziehen kannst.
Gruß
Franz
Sub Dokumentdaten_uebertragen()
' Makro am 22.07.07 von fcs erstellt
Dim wksOrdner As Worksheet, wksProjekt As Worksheet, strOrt As String
Dim rngOrdner As Range, rngProjekt As Range, arrZeilen() As Long
Dim Reihe As Long, iZeile As Integer
Set wksOrdner = Worksheets("Ordner Auslesen")
Set wksProjekt = Worksheets("Projektübersicht")
If ActiveSheet.Name wksOrdner.Name Then
MsgBox "Dieses Makro darf nur gestartet werden, wenn das Blatt '" & _
wksOrdner.Name & "' das aktive Blatt ist!!"
Exit Sub
End If
Set rngOrdner = Selection
'Nummern der sichtbaren Zeilen in der Auswahl in einem Datenfeld merken
iZeile = 0
For Reihe = 1 To rngOrdner.Rows.Count
If rngOrdner.Rows(Reihe).Hidden = False Then
iZeile = iZeile + 1
ReDim Preserve arrZeilen(1 To iZeile)
arrZeilen(iZeile) = rngOrdner.Rows(Reihe).Row
End If
Next
wksProjekt.Activate
If MsgBox("Ist die Einfügezeile korrekt?", vbOKCancel) = vbCancel Then Exit Sub
Set rngProjekt = wksProjekt.Cells(ActiveCell.Row, 1) 'Zelle Spalte A in Einfügezeile
'Merken Speicherort
strOrt = rngProjekt.Offset(0, 3).Value
'Aktuelle Datenzeile kopieren und unterhalb wieder einfügen
rngProjekt.EntireRow.Copy
rngProjekt.Offset(1, 0).Insert Shift:=xlDown
'Daten in Einfüge-Zeile löschen
rngProjekt.EntireRow.ClearContents
'restliche notwendigen Leerzeileneinfügen
If UBound(arrZeilen) > 1 Then
With wksProjekt
.Range(.Rows(rngProjekt.Row + 1), _
.Rows(rngProjekt.Row + UBound(arrZeilen) - 1)).Insert Shift:=xlDown
End With
End If
'Selektierte Daten zeilenweise einfügen
iZeile = 0 'Zähler für Zeilen relativ zur Einfügezeile,
With wksOrdner
For Reihe = LBound(arrZeilen) To UBound(arrZeilen)
'Prüfung ob Speicherort übereinstimmt
'Falls Speicherort in Projektübersicht leer dann wird immer eingetragen _
(1. Dokumente werden in einem Ordner eingetragen)
If strOrt .Cells(arrZeilen(Reihe), 4) And strOrt "" Then
Test = MsgBox("Der Speicherort der im Blatt 'Ordner Auslesen' selektierten Datei: " _
& vbLf & vbLf & .Cells(arrZeilen(Reihe), 6) & vbLf & vbLf _
& "stimmt nicht mit dem in der Projektübersicht gewählten Ordner" _
& vbLf & vbLf & strOrt & vbLf & vbLf _
& "überein! Dokumentdaten werden nicht eingefügt!", vbRetryCancel)
Select Case Test
Case vbRetry
'do nothing
Case vbCancel
GoTo ende
End Select
Else
'Datensatz kopieren
.Range(.Cells(arrZeilen(Reihe), 1), .Cells(arrZeilen(Reihe), 7)).Copy _
Destination:=rngProjekt.Offset(iZeile, 0)
'Inhalt in übertragener Zeile löschen (Doppelübertragung verhindern)
.Rows(arrZeilen(Reihe)).ClearContents
iZeile = iZeile + 1
End If
Next
End With
ende:
rngProjekt.Select
With wksProjekt
'ggf. Leerzeilen wieder löschen wenn abgebrochen oder Zeile übersprungen wurde
If iZeile UBound(arrZeilen) Then
.Range(.Rows(rngProjekt.Row + iZeile), _
.Rows(rngProjekt.Row + UBound(arrZeilen) - 1)).Delete Shift:=xlUp
End If
End With
End Sub