Kopiere aus Datei Zeile, wenn Bedingung erfüllt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Kopiere aus Datei Zeile, wenn Bedingung erfüllt

18.10.2017 09:26:51

AW: Kopiere aus Datei Zeile, wenn Bedingung erfüllt

18.10.2017 09:31:40

Chris

So z.B.

18.10.2017 09:58:25

Peter(silie)

AW: So z.B.

18.10.2017 10:09:05

Chris

AW: So z.B.

18.10.2017 10:10:32

Chris

AW: So z.B.

18.10.2017 10:24:51

Peter(silie)

AW: So z.B.

18.10.2017 10:44:24

Chris

AW: So z.B.

18.10.2017 10:57:26

Peter(silie)

AW: So z.B.

18.10.2017 11:06:32

Chris

AW: So z.B.

18.10.2017 11:07:19

Chris

AW: So z.B.

18.10.2017 11:44:14

Peter(silie)

AW: So z.B.

18.10.2017 12:07:08

Chris

Option Explicit Sub Transfer_Data() Dim lRow, rowToCopy As Long Dim ws_Daten, ws_mitglieder As Worksheet Dim rng, tmp As Range Set ws_Daten = ThisWorkbook.Sheets(1) With ws_Daten lRow = .Cells(.Rows.Count, 4).End(xlUp).Row Set rng = .Range(.Cells(1, 4), .Cells(lRow, 4)) rowToCopy = Get_Row_of_Match(rng, "T_TL xxx oooo") If rowToCopy > 0 Then Set tmp = .Range(.Cells(rowToCopy, 2), .Cells(rowToCopy, 4)) Set ws_mitglieder = ThisWorkbook.Sheets(2) With ws_mitglieder lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Range("A" & lRow).Resize(, tmp.Columns.Count) = tmp.Value End With Set tmp = Nothing Set ws_mitglieder = Nothing End If End With End Sub Private Function Get_Row_of_Match(ByVal rng As Range, ByVal MatchToFind As Variant) As Long If Not VBA.IsError(Application.Match(MatchToFind, rng, 0)) Then Get_Row_of_Match = Application.Match(MatchToFind, rng, 0) End If End Function

Option Explicit Sub Transfer_Data() Dim ws_Daten As Worksheet Dim rowsToCopy As Variant Dim rng, tmp As Range Dim lRow As Long Set ws_Daten = ThisWorkbook.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 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 Boolean Dim varItem As Variant Dim ws As Worksheet Dim wb As Workbook Dim lRow As Long Dim tmp As Range Set wb = Workbooks.Open("Dein WB Pfad") Set ws = wb.Sheets("Worksheet wo es rein soll") With ws lRow = .Cells(.Rows.Count, 1).End(xlUp) + 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 End Function

Hallo,
viel muss man daran nicht ändern...
Zur Funktionalität:
Workbook öffnen wo die Daten rein kommen sollen.
Alt + F11, dann ein neues Modul erstellen
In Modul den folgenden Code einfügen:

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) 'Anpassen
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) + 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
End Function

Workbook Pfad, Workbook Passwort und Worksheet Namen anpassen.
Ausführen
Fertig

Beliebteste Forumthreads (12 Monate)

Kopiere aus Datei Zeile, wenn Bedingung erfüllt

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

378 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kopiere aus Datei Zeile, wenn Bedingung erfüllt

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

378 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread