Option
Explicit
Sub
Transfer_Data()
Dim
ws_Daten
As
Worksheet
Dim
rowsToCopy
As
Variant
Dim
rng, tmp
As
Range
Dim
wb
As
Workbook
Dim
lRow
As
Long
Set
wb = Workbooks.Open(
"Workbook mit Daten"
)
wb.Unprotect
"Passwort des Workbooks"
Set
ws_Daten = wb.Sheets(1)
With
ws_Daten
lRow = .Cells(.Rows.Count, 4).
End
(xlUp).Row
Set
rng = .Range(.Cells(1, 4), .Cells(lRow, 4))
rowsToCopy = Get_Row_Array(rng,
"T_TL xxx oooo"
)
If
IsArray(rowsToCopy)
Then
Transfer_data_To_other_Workbook rowsToCopy, ws_Daten
End
If
End
With
wb.Protect
"Passwort des Workbooks"
End
Sub
Private
Function
Get_Row_Array(
ByVal
rng
As
Range,
ByVal
ValueToFind
As
Variant
)
As
Variant
Dim
array_()
As
Variant
Dim
counter
As
Long
Dim
firstAddress
Dim
c
As
Range
With
rng
Set
c = .Find(ValueToFind, LookIn:=xlValues, LookAt:=xlWhole)
If
Not
c
Is
Nothing
Then
firstAddress = c.Address
counter = 0
Do
ReDim
Preserve
array_(counter)
array_(counter) = c.Row
counter = counter + 1
Set
c = .FindNext(c)
Loop
While
Not
c
Is
Nothing
And
c.Address <> firstAddress
End
If
End
With
Get_Row_Array = array_
End
Function
Private
Function
Transfer_data_To_other_Workbook(
ByVal
array_
As
Variant
,
ByVal
FromWorksheet _
As
Worksheet)
Dim
varItem
As
Variant
Dim
ws
As
Worksheet
Dim
wb
As
Workbook
Dim
lRow
As
Long
Dim
tmp
As
Range
Set
ws = ThisWorkbook.Sheets(
"Worksheet wo es rein soll"
)
With
ws
lRow = .Cells(.Rows.Count, 1).
End
(xlUp).Row + 1
For
Each
varItem
In
array_
With
FromWorksheet
Set
tmp = .Range(.Cells(varItem, 2), .Cells(varItem, 4))
End
With
.Range(
"A"
& lRow).Resize(, tmp.Columns.Count) = tmp.Value
Set
tmp =
Nothing
lRow = lRow + 1
Next
varItem
End
With