AW: Formular auslesen und Kopieren
09.04.2020 23:56:15
fcs
Hallo Joschka,
hier ein Makro um die Dateien abzuarbeiten und die Daten einzulesen.
Es werden die Werte übertragen.
Den Weg über geschlossene Dateien mussst du dir woanders besorgen. Ich persönlich bevorzuge den Weg die Quell-Dateien kurzzeitig schreibgeschützt zu öffnen.
Ggf. solltest du in den Zeilen 7 und 8 noch die Formate anpassen, damit die Anzeige der Daten korrekt ist. Gilt z.B. für das Antragsdatum in Spalte C.
LG
Franz
Sub prcImportData()
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim zeiZiel As Long, zeiZiel_1 As Long, zeiLast As Long
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, sDateiQuelle As String
Dim arrZellen() As Variant, intZ As Long
Dim varOrdner
Dim StatusCalc As Long
'Ordner-Auswahl
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit Dateien auswählen deren Daten importiert werden sollen"
.AllowMultiSelect = False
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Zuordnung der zu kopierenden Zellen zu den Ziel Spalten
intZ = 3 'Anzahl ggf. anpassen
ReDim arrZellen(1 To intZ, 1 To 2)
'C8 in E, Q8 in H und I22 in C
'in der 1. Spalte des Arras steht die Quellzelle, in der 2. Spalte die Nummer Zielspalte
intZ = 1: arrZellen(intZ, 1) = "C8": arrZellen(intZ, 2) = 5
intZ = intZ + 1: arrZellen(intZ, 1) = "Q8": arrZellen(intZ, 2) = 8
intZ = intZ + 1: arrZellen(intZ, 1) = "I22": arrZellen(intZ, 2) = 3
'usw.
'Zielobjekte zuweisen
Set wkbZiel = ActiveWorkbook
Set wksZiel = wkbZiel.Worksheets("Übersicht")
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
'Altdaten löschen
zeiZiel_1 = 7 '1. Einfüge-Zeile
With wksZiel
zeiLast = .UsedRange.Row + .UsedRange.Rows.Count - 1
If zeiLast >= zeiZiel_1 Then
'Werte löschen
.Range(.Rows(zeiZiel_1), .Rows(zeiLast)).ClearContents
If zeiLast >= zeiZiel_1 + 2 Then
'alle Formate in den Zeilen lösche bis auf die 1. beiden Datenzeilen
.Range(.Rows(zeiZiel_1 + 2), .Rows(zeiLast)).Delete shift:=xlShiftUp
End If
End If
End With
'quelldateien im Ordner suchen und abarbeiten
sDateiQuelle = Dir(varOrdner & "\*.xls*", vbNormal)
zeiZiel = zeiZiel_1
Do Until sDateiQuelle = ""
Application.StatusBar = "Datei Nr. " & zeiZiel - 6 & " wird bearbeitet"
'Quelldatei schreibgeschützt öffnen
Set wkbQuelle = Application.Workbooks.Open(Filename:=varOrdner & "\" _
& sDateiQuelle, ReadOnly:=True)
Set wksQuelle = wkbQuelle.Worksheets(1)
With wksQuelle
wksZiel.Cells(zeiZiel, 2).Value = zeiZiel - zeiZiel_1 + 1
For intZ = 1 To UBound(arrZellen, 1)
wksZiel.Cells(zeiZiel, arrZellen(intZ, 2)).Value = .Range(arrZellen(intZ, 1))
Next intZ
End With
zeiZiel = zeiZiel + 1
wkbQuelle.Close savechanges:=False
sDateiQuelle = Dir
Loop
With wksZiel
If zeiZiel > zeiZiel_1 + 2 Then
'Zeilen-Formate kopieren
.Rows(zeiZiel + 1).Copy
.Range(.Rows(zeiZiel + 2), .Rows(zeiLast)).PasteSpecial Paste:=xlPasteFormats
End If
End With
'Makrobremsen zurücksetzen
With Application
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub