Ich habe nicht einen Link, sondern mehrere Ideen zusammengebaut. So sollen z.B auch Duplikate bei einer aktualisierung sofort beseitigt werden.
Sub Einlesen()
Call EventsOff
Dim Dateien As Integer
Dim DateiName As String
Dim zeile As Long
With Application.FileSearch
.NewSearch
.LookIn = ActiveWorkbook.Path
.Filename = "*.xls"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
DateiName = Dir(.FoundFiles(Dateien))
If DateiName <> ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(Dateien)
zeile = ThisWorkbook.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1
Workbooks(DateiName).Sheets(1).Range("B5:B107").Copy
ThisWorkbook.Sheets(1).Range("A" & zeile).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Workbooks(DateiName).Close
End If
Next Dateien
End If
End With
Call EventsOn
Call DoppelteNr
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub DoppelteNr()
Dim iRow As Integer, iRowL As Integer
iRowL = Cells(Cells.Rows.Count, 1).End(xlUp).Row
For iRow = iRowL To 1 Step -1
If WorksheetFunction.CountIf(Columns(1), Cells(iRow, 1)) > 1 Then
Rows(iRow).Delete
End If
Next iRow
End Sub
Dazu habe ich noch eine Userform eingebaut:
Private Sub Aktualisieren_Click()
Call Einlesen
test.Hide
End Sub
Private Sub UserForm_Click()
End Sub
Vielleicht hilft dies weiteren Usern.
Euer
xxl