Sub InformationenEinfuegen()
Dim Quelle As Worksheet
Dim Zielmappe As Workbook
Dim i As Integer
Dim Blatt As Worksheet
Dim strInhalt As String
Set Zielmappe = Workbooks.Open("C:\b")
Set Quelle = ThisWorkbook.ActiveSheet
With Zielmappe
For Each Blatt In .Worksheets
If InStr(1, Blatt.Name, "GM11_6-", vbBinaryCompare) <> 0 Then
strInhalt = Blatt.Range("B5")
Quelle.Cells.Find(What:= _
strInhalt, After:= _
ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Quelle.Range("B6:I13").Select
Selection.Copy Blatt.Range("B22")
Quelle.Range("B16:Q21").Select
Selection.Copy Blatt.Range("B32")
End If
Next Blatt
End With
End Sub