Hallo Zusammen,
Wiedermal habe ich eine Frage, ich habe einen Code geschrieben mit welchem Ich aus einem Ordner mehrere Dateien auswählen kann und diese danach in meine Liste einlesen kann.
Leider ist dort ein Fehler End With ohne With. Ich finde den Fehler einfach nicht, was muss ich am Code ändern? Hier der Code:
'Daten einlesen
Private Sub CommandButton1_Click()
Dim filSRC As Excel.Workbook
Dim vntSRC As Variant
Dim shtTRG As Excel.Worksheet
Dim rngSearch As Excel.Range
Dim rngZelle As Excel.Range
Dim lngFreieZeile As Long
Dim bolExist As Boolean
Dim iFiles As Long
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Set shtTRG = ThisWorkbook.Sheets("3_Machbarkeit")
With shtTRG
lngFreieZeile = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row + 1
vntSRC = Application.GetOpenFilename("Excel-Arbeitsmappe (*.xls),*.xls,Excel2007-Arbeitsmappe (*.xlsx),*.xlsx", 1, "Importdatei(n) auswählen...", "Importdatei", True)
If IsArray(vntSRC) = True Then
For iFiles = 1 To UBound(vntSRC)
Set filSRC = Application.Workbooks.Open(vntSRC(iFiles), , True): DoEvents
' Set rngSearch = .Range("D1:" & CStr(lngFreieZeile - 1))
bolExist = False
For Each rngZelle In shtTRG.Range("D1:D150")
If rngZelle.Value = filSRC.Sheets(1).Range("D1").Value Then
rngZelle.EntireRow.Columns("B") = filSRC.Sheets(1).Range("B1")
rngZelle.EntireRow.Columns("C") = filSRC.Sheets(1).Range("B1")
rngZelle.EntireRow.Columns("D") = filSRC.Sheets(1).Range("D1")
rngZelle.EntireRow.Columns("E") = filSRC.Sheets(1).Range("B2")
rngZelle.EntireRow.Columns("F") = filSRC.Sheets(1).Range("D2")
bolExist = True
Exit For
End If
Next rngZelle
If bolExist = False Then
.Cells(lngFreieZeile, "B") = filSRC.Sheets(1).Range("B1")
.Cells(lngFreieZeile, "C") = filSRC.Sheets(1).Range("B1")
.Cells(lngFreieZeile, "D") = filSRC.Sheets(1).Range("D1")
.Cells(lngFreieZeile, "E") = filSRC.Sheets(1).Range("B2")
.Cells(lngFreieZeile, "F") = filSRC.Sheets(1).Range("D2")
End If
filSRC.Close False
Set filSRC = Nothing
Set rngSearch = Nothing
Next iFiles
End If
End With
Set shtTRG = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Gruss
Reto |