Option Explicit
Dim wbQuelle As Workbook, wBZiel As Workbook
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim lstQZeile As Integer, lstZZeile As Integer
Sub Datei_Auslesen()
Dim iCount As Integer, i As Integer, strDatei As Variant
Dim strName As String, lstQcolumn As Integer
Dim iQrow, iZrow As Integer, iZcolumn As Integer, iQcolumn As Integer
Set wBZiel = ThisWorkbook
For iCount = 1 To Workbooks.Count
If InStr(Workbooks(iCount).Name, "Datei-Y") Then
Set wbQuelle = Workbooks(iCount)
Set wsQuelle = wbQuelle.Sheets(1)
End If
Next iCount
If wbQuelle Is Nothing Then
strDatei = Application.GetOpenFilename
If strDatei <> False Then
Set wbQuelle = Workbooks.Open(strDatei)
Set wsQuelle = wbQuelle.Sheets(1)
Else:
GoTo Ende
End If
End If
Windows(wBZiel.Name).Activate
lstQZeile = wsQuelle.Cells(20000, 2).End(xlUp).Row
lstQcolumn = wsQuelle.Cells(5, 256).End(xlToLeft).Column - 1
For i = 4 To lstQcolumn
If wsQuelle.Cells(5, i) <> "" Then
strName = wsQuelle.Cells(5, i)
Set wsZiel = ThisWorkbook.Worksheets(strName)
lstZZeile = wsZiel.Cells(20000, 1).End(xlUp).Row
End If
For iQrow = 7 To lstQZeile
For iZrow = 5 To lstZZeile
If wsQuelle.Cells(iQrow, 2) = wsZiel.Cells(iZrow, 1) Then
iQcolumn = i
Do While iQcolumn < lstQcolumn
If wsQuelle.Cells(5, iQcolumn + 1) <> "" Then Exit Do
For iZcolumn = 3 To 26
If InStr(wsZiel.Cells(1, iZcolumn), wsQuelle.Cells(6, iQcolumn)) Then
wsZiel.Cells(iZrow, iZcolumn) = wsQuelle.Cells(iQrow, iQcolumn)
End If
Next iZcolumn
iQcolumn = iQcolumn + 1
Loop
End If
Next iZrow
Next iQrow
Next i
Set wBZiel = Nothing
Set wsZiel = Nothing
Set wbQuelle = Nothing
Set wsQuelle = Nothing
Exit Sub
Ende:
MsgBox "Es wurde keine Datei ausgewählt, Programm wird abgebrochen!", vbExclamation
Set wBZiel = Nothing
Set wsZiel = Nothing
Set wbQuelle = Nothing
Set wsQuelle = Nothing
End Sub