PDA

Vollständige Version anzeigen : Weiteres Ergebnis in neuer Zeile einfügen


anni87
07.07.2014, 13:44
Hallo,

ich möchte einen Vergleich erweitern, so dass bei einem zweiten gefundenen Ergebnis eine neue Zeile unter der vorherigen eingefügt wird. Nur weiß ich absolut nicht, wo ich den Befehl (wenn dieser stimmt ;) )

Rows.Select
Selection.Insert
Shift:=xlDown


einfügen soll.

Mein jetziger Code sieht wie folgt aus:

If Tab2.Cells(Zeile, 10).Value = Tab3.Cells(Zeile2, 1).Value Then
Set aErgebnis = Tab2.Cells(Zeile, 2)
End If
If Not aErgebnis Is Nothing Then
Tab3.Cells(Zeile2, 4).Value = aErgebnis.Value

Set aErgebnis = Nothing
End If
Next
Next

Kann mir da jemand helfen?

Oder sollte ich lieber auf einen weiteren Vergleich zurückgreifen?

If .Cells(Zeile2, 4).Value <> .Cells(Zeile2+1, 4).Value Then
Rows(ZEile2+1).Insert
Zeile2=Zeile2+1

GMG-CC
07.07.2014, 13:58
Moin,

um seriös antworten zu können ohne Gefahr zu laufen, für den Papierkorb zu arbeiten, brauchen wir als MINDESTES den kompletten Code (Sub oder Function), besser noch die komplette (anonymisierte) Datei.

anni87
07.07.2014, 14:26
Hallo,

ich habe mir nun Nachnahmen ausgedacht und Datei um die nicht relevanten Tabellenblätter gekürzt.

Es sollen die Nachnamen aus "Personell" in "Pax-DROMLAN" übernommen werden und nahand der Flüge zugeordnet werden.

Bitte nicht wundern, der Code dauert sehr lange...

Der komplette Code sieht wie folgt aus:

ub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim Zeile As Long
Dim Zeile2 As Long
Dim aErgebnis As Range
Dim Meldung As Integer
Dim Meldung2 As Integer

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

Meldung2 = MsgBox("Die Übertragung der Daten dauert etwas!", vbInformation)


For Zeile = 7 To 230
For Zeile2 = 6 To 293

'Probe mit nur Nachnamen übertragen

If Tab2.Cells(Zeile, 10).Value = Tab3.Cells(Zeile2, 1).Value Then
Set aErgebnis = Tab2.Cells(Zeile, 2)
End If
If Not aErgebnis Is Nothing Then
Tab3.Cells(Zeile2, 4).Value = aErgebnis.Value

Set aErgebnis = Nothing
End If
Next
Next


Meldung = MsgBox("Die Übertragung der Daten ist abgeschlossen!", vbInformation)

End Sub

GMG-CC
07.07.2014, 19:04
OK Anni,

etwas mehr Licht ist schon ins Dunkel gekommen.
Ich kann den Code lesen
ich verstehe auch jede Zeile einzeln
ich verstehe aber nicht wirklich den Zusammenhang.
Das liegt wahrscheinlich an der etwas eigenwilligen Syntax ...

Vorschlag: Beschreibe bitte einmal global und auch in KLEINSTEN Schritten, was im Moment in Modul3 passiert. Ich gehe erst einmal davon aus, dass sich die Zeit auf <=10% schrumpfen lässt, falls meine Vermutung zutrifft.

So, und jetzt beschreibe bitte, wie sich das ändern soll. Was kann das Modul noch nicht?

Was ich jetzt so sehe:
In Tab2:

Beginne in Zeile_7 bis zur letzten Zeile
Hole den Wert aus der aktuellen Zeile Spalte_10 (J) und vergleiche ihn nacheinander mit dem Wert aus Tab3, jeweils A6 bis A293.
Wenn die Ergebnisse gleich sind, dann soll in Tab3, aktuelleZeile/Spalte_D der eben gefundene Wert geschrieben werden.
Und dann die nächste Zeile aus Tab2 ...

-->> Irritierend ...

Wie gesagt, schreibe es mal mit deinen Worten.

Mc Santa
07.07.2014, 20:01
Hallo,

ich habe mir nun Nachnahmen ausgedacht und Datei um die nicht relevanten Tabellenblätter gekürzt.

Es sollen die Nachnamen aus "Personell" in "Pax-DROMLAN" übernommen werden und nahand der Flüge zugeordnet werden.

Bitte nicht wundern, der Code dauert sehr lange...

Der komplette Code sieht wie folgt aus:

ub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim Zeile As Long
Dim Zeile2 As Long
Dim aErgebnis As Range
Dim Meldung As Integer
Dim Meldung2 As Integer

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

Meldung2 = MsgBox("Die Übertragung der Daten dauert etwas!", vbInformation)


For Zeile = 7 To 230
For Zeile2 = 6 To 293

'Probe mit nur Nachnamen übertragen

If Tab2.Cells(Zeile, 10).Value = Tab3.Cells(Zeile2, 1).Value Then
Set aErgebnis = Tab2.Cells(Zeile, 2)
End If
If Not aErgebnis Is Nothing Then
Tab3.Cells(Zeile2, 4).Value = aErgebnis.Value

Set aErgebnis = Nothing
End If
Next
Next


Meldung = MsgBox("Die Übertragung der Daten ist abgeschlossen!", vbInformation)

End Sub


Hallo,

ich habe dir den oben stehenden Code mal in der gleichen Funktionalität so umgeschrieben, dass er schnell ist.
Mir ist nicht ganz klar, ob zusätzliche Namen einfach unten drunter sollen, oder ob du tatsächlich eine eingefügt Zeile brauchst, daher überschreibt mein Code die Namen (wie bisher auch deiner) einfach den alten.

Hoffe dieser Ansatz hilft dir weiter :)

VG

PS: vermutlich kannst du dir jetzt die warnende MsgBix sparen ;)

Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

MsgBox "Die Übertragung der Daten dauert etwas!", vbInformation

lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
Tab3.Cells(rFind.Row, 4) = Tab2.Cells(rng.Row, 2)
End If
End If
Next
MsgBox "Die Übertragung der Daten ist abgeschlossen!", vbInformation

End Sub

anni87
08.07.2014, 07:40
Hallo,

Hallo,

ich habe dir den oben stehenden Code mal in der gleichen Funktionalität so umgeschrieben, dass er schnell ist.
Mir ist nicht ganz klar, ob zusätzliche Namen einfach unten drunter sollen, oder ob du tatsächlich eine eingefügt Zeile brauchst, daher überschreibt mein Code die Namen (wie bisher auch deiner) einfach den alten.

Hoffe dieser Ansatz hilft dir weiter

VG

PS: vermutlich kannst du dir jetzt die warnende MsgBix sparen


schon mal vielen Dank. Der Code ist nun echt um Welten schneller und ich habe die MsgBix gelöscht ;)

Vorschlag: Beschreibe bitte einmal global und auch in KLEINSTEN Schritten, was im Moment in Modul3 passiert. Ich gehe erst einmal davon aus, dass sich die Zeit auf <=10% schrumpfen lässt, falls meine Vermutung zutrifft.

So, und jetzt beschreibe bitte, wie sich das ändern soll. Was kann das Modul noch nicht?

Was ich jetzt so sehe:
In Tab2:

Beginne in Zeile_7 bis zur letzten Zeile
Hole den Wert aus der aktuellen Zeile Spalte_10 (J) und vergleiche ihn nacheinander mit dem Wert aus Tab3, jeweils A6 bis A293.
Wenn die Ergebnisse gleich sind, dann soll in Tab3, aktuelleZeile/Spalte_D der eben gefundene Wert geschrieben werden.
Und dann die nächste Zeile aus Tab2 ...

-->> Irritierend ...

Wie gesagt, schreibe es mal mit deinen Worten.

Ich werde es mal versuchen:


Beginne in Tab2 Zeile7


Vergleich den Wert (Flugdaten), wenn dieser nicht "" mit Tab3 Spalte A (Flugdaten)


Sind die Werte gleich, dann übernehme den Nachnamen aus Tab2 (Spalte B) in Tab3 (Spalte D)


Danach prüfe die nächste Zeile in Tab2, bis alle Zeilen in Tab2 geprüft wurden


Das Modul soll, dabei nicht nur den letzten Nachnahmen nach einem Vergleich der Flugdaten, sondern alle Nachnamen (mit den selben Flugdaten) in Tab3 (Spalte D) übertragen. Wenn es mehrere Ergebnisse gibt, sollen diese in neuen Zeilen unter dem ersten gefundenen Nachnamen erscheinen.

Ich hoffe es ist nun verständlicher...

Mc Santa
08.07.2014, 07:44
Hallo,

ok für mich ist es verständlich. Eine Frage und eine Bitte noch:
Soll in der eingefügten Zeile irgendwo noch etwas stehen (zb in Spalte A der Flughafen?)
Und: hast du die Datei auch im .zip-Format? Habe hier leider nichts zum öffnen.

VG

anni87
08.07.2014, 08:11
Hallo in SpalteA Tab3 soll nichts weiter stehen.

Vielen Dnak für deine Hilfe...

Mc Santa
08.07.2014, 08:34
Hallo,

folgender Vorschlag:
Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range, helpR As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")


lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row, 4)
If .Value = "" Then
.Value = Tab2.Cells(rng.Row, 2)
Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Offset(1) = Tab2.Cells(rng.Row, 2)
End If
End With
End If
End If
Next
End Sub
der blaue Teil ist neu :)

Ist es so, wie du es dir vorgestellt hast?

VG

anni87
08.07.2014, 08:47
Ja vielen Dank.

Genau so, sollte es sein...

Nun muss ich es nur noch hinbekommen, dass die alten Daten erste gelöscht werden und dann neu generiert werden, damit keine Daten doppelt vorkommen...

anni87
08.07.2014, 08:55
Habe nun noch das löschen eingefügt und alles klappt. Vielen Dank nochmal, der Code sieht nun so aus:

Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range, helpR As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

'alte Daten löschen

Tab3.Range(Tab3.Cells(6, 4), Tab3.Cells(293, 4)).ClearContents

'neue Daten generieren

lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row, 4)
If .Value = "" Then
.Value = Tab2.Cells(rng.Row, 2)
Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Offset(1) = Tab2.Cells(rng.Row, 2)
End If
End With
End If
End If
Next
End Sub

Mc Santa
08.07.2014, 08:57
Ja vielen Dank.

Genau so, sollte es sein...

Nun muss ich es nur noch hinbekommen, dass die alten Daten erste gelöscht werden und dann neu generiert werden, damit keine Daten doppelt vorkommen...

Das habe ich mir fast gedacht ;)

Allerdings stoße ich auf ein Problem: Gibt es immer die drei Leerzellen unter den Namen? Oder steht dort auch manchmal etwas anderes? Wenn dort auch etwas anderes stehen kann: Wie erkenne ich die "Grenze" zwischen den Einträgen?

VG

Ah, du hast schon eine Lösung :)
Danke, dass du sie auch mit allen anderen teilst, die vielleicht mitlesen!

anni87
08.07.2014, 13:17
Hey,

wie kann ich den Code den so erwitern, dass mach einem erfolgreichen Vergleich nicht nur die Daten TAb2.SpalteB nach Tab3.SpalteD übernommen werden, sondern die Daten Tab2.B-G nach Tab3.D-I?

Lieben Gruß

anni87

anni87
08.07.2014, 13:20
Allerdings stoße ich auf ein Problem: Gibt es immer die drei Leerzellen unter den Namen? Oder steht dort auch manchmal etwas anderes? Wenn dort auch etwas anderes stehen kann: Wie erkenne ich die "Grenze" zwischen den Einträgen?


Die drei leeren Zeilen sollen als "Grenze" stehen. Kann man das mit einbauen?

LG Anni

Mc Santa
08.07.2014, 14:11
Hallo,

hier einmal der Code zum Einfügen der Spalten B-G:
Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range, helpR As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

'alte Daten löschen

Tab3.Range(Tab3.Cells(6, 4), Tab3.Cells(293, 4)).ClearContents

'neue Daten generieren

lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row, 4)
If .Value = "" Then
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Cells(1, 1).PasteSpecial xlPasteValues
Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Offset(1).PasteSpecial xlPasteValues
End If
End With
End If
End If
Next
End Sub

Für das löschen habe ich noch keine so gute Idee, zumal du ja vermutlich auch noch "Pax out" befüllen willst mit den Daten aus Personnel.
Vielleicht sollte man dann über eine andere Struktur deiner Tabelle nachdenken, oder in Spalte A bessere "Anker" setzen für den Code. Man könnte dann darüber die Zeilen löschen.

VG

anni87
08.07.2014, 14:24
Hey,

Für das löschen habe ich noch keine so gute Idee, zumal du ja vermutlich auch noch "Pax out" befüllen willst mit den Daten aus Personnel.
Vielleicht sollte man dann über eine andere Struktur deiner Tabelle nachdenken, oder in Spalte A bessere "Anker" setzen für den Code. Man könnte dann darüber die Zeilen löschen

Ja "Pax out" muss auch noch mit den Daten der persoenen nach einem Vergleich TAb2.Spalte11 mit Tab3.Spalte1 befüllt werden.

Was meinst du mit "Anker"?

Mc Santa
08.07.2014, 14:33
Mal ganz grob meine Idee:

Ich würde in Spalte A folgende Dinge schreiben: "D1_in", "D1_out", usw und "Grenze". Alle Zeilen die du behalten willst, sollten in Spalte A einen Wert haben.
Anschließend können über das Makro Zeilen eingefügt werden. Dort steht dann in Spalte A nichts.
Später könnte man alle Zeilen markieren (oder besser einen Bereich: Zeilen 5-100), die in Spalte A nichts stehen haben. Diese Zeilen werden dann gelöscht.

Der Code zum Löschen sieht dann etwa so aus:
Range("A5:A50").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Hilft dir das weiter?
VG

anni87
08.07.2014, 14:38
Ja ich denke mal schon, werde es morgen mal ausprobieren und dann kurz berichten...

Vielen Dank

LG

anni87
09.07.2014, 07:42
Hey,

ich habe nun das TAb3 so umgebaut, dass ich in Spalte A D1_in usw. eingetragen habe.

Wie bekomme ich den nun den Code umgebaut, dass die Daten in Tab2 auch mit den Daten in der SpalteA Tab3 gefunden werden können?

Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range, helpR As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

'alte Daten löschen noch den Anker einbauen

'Tab3.Range("A5:A200").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'neue Daten generieren in pax in

lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row, 4)
If .Value = "" Then
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Cells(1, 1).PasteSpecial xlPasteValues
Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Offset(1).PasteSpecial xlPasteValues
End If
End With
End If
End If
Next


'neue Daten für Pax out


End Sub



Oder muss ich die Daten in Tab2 auch ändern?

Liebe Grüße
anni87

Mc Santa
09.07.2014, 08:05
Hallo,

du müsstest vermutlich die markierte Stelle ändern und es dann so ähnlich auch für Pax out machen.

Lade am besten mal den neuen Stand deiner Datei hoch. Habe heute nicht so viel Zeit, aber wie ich mich kenne werde ich dann mal drüber gucken und meistens ist es produktiv :grins:

VG

Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range, helpR As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

'alte Daten löschen noch den Anker einbauen

'Tab3.Range("A5:A200").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'neue Daten generieren in pax in

lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value & "_in", _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row, 4)
If .Value = "" Then
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Cells(1, 1).PasteSpecial xlPasteValues
Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Offset(1).PasteSpecial xlPasteValues
End If
End With
End If
End If
Next


'neue Daten für Pax out


End Sub

anni87
09.07.2014, 08:50
ok,

hier ist einmal die Datei, mit dem neuen Makro...

Danke dir!!!

Wie kann ich den Makro umschreiben, sodass gleich nach dem ersten Vergleich mit D1_in eine neue Zeile eingefügt wird, wenn ein Ergebnis gefunden wird. Damit auch dieses gleich mit gelöscht wird, bei einer Aktualisierung...

Lieben Gruß
anni87

anni87
09.07.2014, 09:42
Hallo @all,

der folgende Code klappt nun...

Sub Schaltfläche1_Klicken()

Dim Tab2 As Worksheet
Dim Tab3 As Worksheet
Dim rng As Range, rFind As Range, helpR As Range
Dim lngLast As Long

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

'alte Daten löschen noch den Anker einbauen

Tab3.Range("A5:A250").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'neue Daten generieren in pax in

lngLast = IIf(Tab2.Cells(230, 10).Value <> "", 230, Tab2.Cells(230, 10).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 10), Tab2.Cells(lngLast, 10))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value & "_in", _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row + 1, 4)
If .Value = "" Then
'Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
' .Cells(1, 1).PasteSpecial xlPasteValues
'Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Offset(1).PasteSpecial xlPasteValues
End If
End With
End If
End If
Next



'neue Daten für Pax out

Set Tab2 = Worksheets("Personnel")
Set Tab3 = Worksheets("Pax-DROMLAN")

lngLast = IIf(Tab2.Cells(230, 11).Value <> "", 230, Tab2.Cells(230, 11).End(xlUp).Row)
For Each rng In Tab2.Range(Tab2.Cells(7, 11), Tab2.Cells(lngLast, 11))
If Not rng.Value = "" Then
Set rFind = Nothing
Set rFind = Tab3.Range(Tab3.Cells(6, 1), Tab3.Cells(293, 1)).Find(What:=rng.Value & "_out", _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
With Tab3.Cells(rFind.Row + 1, 4)
If .Value = "" Then
'Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
'.Cells(1, 1).PasteSpecial xlPasteValues
'Else
.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Tab2.Cells(rng.Row, 2).Resize(, 6).Copy
.Offset(1).PasteSpecial xlPasteValues
End If
End With
End If
End If
Next
End Sub