Office: Bestimmte Zellen kopieren und Einfügen vba

Hallo zusammen,

Ich bekomme es leider nicht hin... Seit 1 Stunde tu ich schon rum nur ohne Erfolg.

Ich würde gerne per VBA in Spalte D nach Zelleninhalt suchen wie zb. "Max". Falls dies der Fall ist, den Wert neben der Spalte D ( also Spalte E) kopieren und untereinander ab Zelle ("G2") kopieren lassen...

ich hab vor einiger zeit nach einen VBA Code hier gefragt für das Löschen bestimmter Zeilen, falls ein Bestimmter Wert in einer Spalte befindet. Diesen Code konnte ich leider nicht für mein Fall umsetzen ....

PHP:

         Sub CopyPaste()
Dim wks As Worksheet
Dim i As Integer
Dim n As Integer
Dim intLR As Integer

intLR = wks.Range("D250").End(xlUp).Row
With wks
For n = 1 To intLR

If InStr(1, .Cells(n, 4).Value, "Max") Then
.Cells(n, 5).Copy
n = n - 1
Else

End If

Next n
End With


End Sub


:)

 

Hi,

Code:

 

Vielen Dank für Die Antwort!

er kopiert mir leider nur den Ersten Wert der in der Zeile Max steht
Und das kopiert er mir in die letzte leere Zeile von Spalte 7

Ich habe mehrere Max Werte. Ich weiß jetzt nicht so genau an sich wie ich bei Deinem Makro eine For Schleife einbauen kann..

Sieht für mich zu kompliziert aus und so fit bin ich nun auch wider nicht in Vba ....

Dennoch herzlichen Dank *Smilie

 

1. dein Eröffnungsbeitrag ist nicht eindeutig formuliert: ich habe ihn nicht so verstanden, dass der Begriff mehrfach auftauchen kann sondern dass die Suche mit unterschiedlichen Begriffen wiederholt durchgeführt wird
2. in deinem Beitrag steht, dass in Spalte G ab Zeile 2 untereinander kopiert werden soll - genau das macht der Code

Mit folgendem Code wenden alle Treffer gefunden:

Code:

 

Vielen Dank!

Entschuldige für meine Formulierungen beim ersten Beitrag...

Es klappt wunderbar *Smilie

 

Hallo Beverly,

Da dein Makro super funktioniert, würde ich gerne mit dein Makro weiter arbeiten.

Nun ist das Problem, dass alle Zellen in Spalte D kopiert werden müssen, die einen Wert kleiner 20 aufweisen! Und Nun aber nicht die Spalte neben dem gesuchten Wert, sondern genau die Zellen in Spalte D müssen kopiert werden...

Bin ganze Zeit am Probieren, bekomme es aber leider nicht hin ...

Ich hoffe du kannst mir da weiter helfen *Smilie

PHP:

         Sub unter20()
Dim lngLetzte As Long
Dim rngZelle As Range
Dim strStart As String
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 11)), Cells(Rows.Count, 11).End(xlUp).Row, Rows.Count) + 1
Set rngZelle = Columns(4).Value < 20
If Not rngZelle Is Nothing Then
strStart = rngZelle.Address
Do
rngZelle.Offset(0, 4).Copy Cells(lngLetzte, 11)
lngLetzte = lngLetzte + 1
Set rngZelle = Columns(1).FindNext(rngZelle)
Loop While rngZelle.Address <> strStart
End If
Set rngZelle = Nothing

End Sub


 

Hi,

meinst du so etwas:

Code:

 

An Sich ja *Smilie

Nur wäre es wunderbar, wenn alle zu kopierenden Zellen wieder untereinander eingefügt werden *biggrin.gif*

Noch ein "kleiner Mangel", ist dass Zellen mit kopiert werden, die keine Zahlen beinhalten: zb verbundene Zellen. Bei denen wird aber nur der Format kopiert, dh. die Zellenfarbe oder Rahmen der verbundenen Zellen ( der Inhalt wird nicht kopiert )

Wenn es möglich, wäre dies zu beseitigen durch vba, wäre ich dir sehr dankbar *Smilie

Gruß

PHP:

         Sub unter20()
Dim lngLetzte As Long
Dim lngZeile As Long
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 4)), Cells(Rows.Count, 4).End(xlUp).Row, Rows.Count) + 1
For lngZeile = 1 To IIf(IsEmpty(Cells(Rows.Count, 4)), Cells(Rows.Count, 4).End(xlUp).Row, Rows.Count)
If Cells(lngZeile, 4) < 20 Then
Cells(lngZeile, 4).Copy Cells(lngLetzte, 4)
lngLetzte = lngLetzte + 1
End If
Next lngZeile

lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 11)), Cells(Rows.Count, 11).End(xlUp).Row, Rows.Count) + 1
For lngZeile = 1 To IIf(IsEmpty(Cells(Rows.Count, 11)), Cells(Rows.Count, 11).End(xlUp).Row, Rows.Count)
If Cells(lngZeile, 11) < 70 Then
Cells(lngZeile, 11).Copy Cells(lngLetzte, 11)
lngLetzte = lngLetzte + 1
End If
Next lngZeile

lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 18)), Cells(Rows.Count, 18).End(xlUp).Row, Rows.Count) + 1
For lngZeile = 1 To IIf(IsEmpty(Cells(Rows.Count, 18)), Cells(Rows.Count, 18).End(xlUp).Row, Rows.Count)
If Cells(lngZeile, 18) < 70 Then
Cells(lngZeile, 18).Copy Cells(lngLetzte, 18)
lngLetzte = lngLetzte + 1
End If
Next lngZeile

End Sub


 

Hi,

mit der Codezeile

Code:

kopierst du aus Spalte 4 wiederum nach Spalte 4 - was soll das ganze? Die selbe Frage stellt sich für Spalte 11 und Spalte 18.

 

Nein,

Die Einträge sollen unter der Spalte kopiert werden!

Sprich in der Spalte 4 befinden sich Einträge die bis zu n Zeile in der Spalte 4 gehen.

Und Bestimmte Einträge (

 

Steht in allen 3 Spalten dieselbe Anzahl an Daten oder unterschiedliche?

 

unterschiedliche

Ebenso sind einige verknüpfte Zellen dazwischen, welche dann mit kopiert werden (zumindest die Formatierung)

 

Also wenn ich deinen Code in meiner Mappe ablaufen lassen, funktioniert er genau so wie gewünscht, aber NUR, wenn es keine verbundenen Zellen gibt!! Verbundene Zellen lehne ich definitv ab, weil sie nur Problem bereiten.

 

Okay, Dennoch vielen dank für deine Hilfe *Smilie

 

Ich möchte ungern ein neues Thread eröffnen, da mein Problem eigentlich fast dem oben genannten Problem entspricht.

Nur weiß ich leider nicht wie ich das umsetzen kann...
Ich würde gerne in Spalte P Nach bestimmten Einträgen suchen ( zB. 1) und die komplette Zeile in ein neues Worksheet (Wire1)kopieren...

PHP:

         Sub kopieren()
Dim lngLetzte As Long
Dim lngZeile As Long
Dim WS As Worksheet

For Each WS In Worksheets
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 16)), Cells(Rows.Count, 16).End(xlUp).Row, Rows.Count) + 1
For lngZeile = 1 To IIf(IsEmpty(Cells(Rows.Count, 16)), Cells(Rows.Count, 16).End(xlUp).Row, Rows.Count)
If Cells(lngZeile, 16) = 1 Then
Rng.EntireRow(lngZeile).Copy Worksheets("Wire1").Rows(iRow)
End If

Next lngZeile
Next WS
End Sub