Kopiere aus Datei Zeile, wenn Bedingung erfüllt

Chris · 2017-10-18T08:41:57+00:00

Hallo liebe VBA-Gemeinde, ich suche eine Lösung um Zeilen (oder gerne auch nur bestimmte Zellen) aus einer Datei in meine aktive zu kopieren wenn die Bedingung erfüllt ist. Ich habe in meiner Quellen-Datei, mehrere Worksheets. im betroffen WS "MA DATEN" habe ich 5 Spalten: id personnel-number name User Team Department 3072 500302 xxx,ffffff kürzel1 0 0 3079 500002 xxxx,ccccc kürzel2 T_TL xxx oooo T_Dep_00-L1_oooo_dddd gesucht werden soll nach Team, in dem Beispiel "T_TL xxx oooo", wenn der in der Spalte steht, dann kopiere Zeile (oder Zellen 2-4 in der Zeile) in Zieldatei, Worksheet "Teammitglieder" untereinander. Zeile oder bestimmte Zellen wäre mir egal.

Hallo,
dann könntest du folgenden Code probieren der mit .Find und .FindNext arbeitet.
Worksheet, Workbook und Range Variablen musst du auf dich anpassen!

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

Kopiere aus Datei Zeile, wenn Bedingung erfüllt

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

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Kopiere aus Datei Zeile, wenn Bedingung erfüllt

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

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread