Sub
übertrag()
Dim
lzeile
As
Long
Dim
lspalte
As
Long
Dim
blätter()
Dim
blatt
Dim
anzahl
As
Long
Dim
i
As
Long
Dim
j
As
Long
Dim
index
ReDim
blätter(0)
anzahl = 0
For
Each
blatt
In
Worksheets
anzahl = anzahl + 1
ReDim
Preserve
blätter(anzahl)
blätter(anzahl) = blatt.Name
Next
blatt
lzeile = ActiveSheet.Cells(Rows.Count, 1).
End
(xlUp).Row
lspalte = ActiveSheet.Cells(1, Columns.Count).
End
(xlToLeft).Column
For
i = 5
To
lzeile
If
ActiveSheet.Cells(i, 1) <>
""
Then
index = ActiveSheet.Cells(i, 1)
If
UBound(Filter(blätter, index)) > -1
Then
For
j = 1
To
lspalte
If
InStr(1, ActiveSheet.Cells(1, j),
"16"
, vbTextCompare)
Then
ActiveSheet.Cells(i, j) = Worksheets(index).Cells(2, Application.WorksheetFunction.Match(ActiveSheet.Cells(1, j), Worksheets(index).Rows(1), 0))
End
If
Next
j
End
If
End
If
Next
i
End
Sub