Office: Zeile kopieren wenn Bedingung (Dezimalzahl) erfüllt.

RaSo0603 · 23. August 2015

Hallo Leute,

bin neu hier im Forum und noch Frischling bei der VBA-Programmierung.
Bisher habe ich alles hier gefunden doch jetzt habe ich ein Problem
(für andere ist dies vermutlich keines) und komme nicht dahinter wo mein
Fehler liegt.

Die Aufgabe ist diese, die Zeilen nach dem Durchmesser (Spalte C) zu
durchsuchen und die kompletten Zeilen z.B. von Durchmesser 1,90 in ein
neues (zuvor angelegtes) Tabellenblatt zu schreiben. Dies muss dann mit
allen vorhandenen Durchmessern geschehen.

Anbei eine Testtabelle mit dem VBA-Prog. dahinter.

Meine Vermutung liegt darin, dass es Probleme mit den Dezimalstellen gibt.

Vorab vielen Dank für Eure Hilfe.

Grüßle

RaSo0603

:)

Klaus-Dieter · 24. August 2015

Hallo,

habe das mal überarbeitet. Siehe Kommentare '# ....

Code:

Sub Copy_Durchmesser()
'
' Makro Tabellenblätter "Tabelle2" und "Tabelle3" leeren.
'
Worksheets("Tabelle2").Range("A2:F500").Clear
Worksheets("Tabelle3").Range("A2:F500").Clear
'
' Sortierung_Durchmesser Makro
' Makro zur Sortierung nach Durchmesser (in Spalte C) und kopieren der kompl. Zeile in Tabellenblatt "Tabelle2".
'
'
Dim shtSrc As Worksheet, shtTarget As Worksheet
Dim rng As Range
Dim strFirst As String, strSearch() As Variant, strSheets() As Variant '# Array-Variablen müssen als Variant deklariert werden

'Suchgbegriffe
strSearch = Array(1.9, 3) '# Dezimalstellen werden in VBA durch Punkt getrennt. 3,0 ist mathematisch nicht korrekt.

'Tabellen in der Reihenfolge der Suchbegriffe
strSheets = Array("Tabelle2", "Tabelle3")

Set shtSrc = Sheets("Tabelle1")

With shtSrc
For lngIndex = 0 To UBound(strSearch)
strFirst = ""
Set rng = Nothing
Set shtTarget = Sheets(strSheets(lngIndex))

Set rng = .Range("C:C").Find(What:=strSearch(lngIndex), LookAt:=xlPart, LookIn:=xlValues, MatchCase:=False)

If Not rng Is Nothing Then
strFirst = rng.Address
Do
rng.EntireRow.Copy shtTarget.Cells(shtTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Set rng = .Range("C:C").FindNext(rng)
Loop While Not rng Is Nothing And strFirst rng.Address
End If
Next
End With

Set rng = Nothing
Set shtTarget = Nothing
Set shtSrc = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

RaSo0603 · 24. August 2015

Hallo Klaus-Dieter,

erst mal vielen Dank für Deine schnelle Hilfe.
Klappt auch soweit, jedoch brauche ich auch den Durchmesser 3,0
aufgelistet. Allerdings wenn ich den Wert 3 eingebe, listet das System mir
alle Durchmesser auf, in dem sich die Zahl 3 befindet.

Gibt es da eine andere Möglichkeit, diese Werte x,00 aufzulisten?

Grüßle
RaSo

Scorefun · 25. August 2015

Code:

Set rng = .Range("C:C").Find(What:=strSearch(lngIndex), LookAt:=xlPart, LookIn:=xlValues, MatchCase:=False)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dann sollte der rot markierte Teil wahrscheinlich auf xlWhole geändert werden

Klaus-Dieter · 25. August 2015

Hallo,

wenn du nur 3,0 finden möchtest, geht das so:

Code:

Sub Copy_Durchmesser()
'
' Makro Tabellenblätter "Tabelle2" und "Tabelle3" leeren.
'
Worksheets("Tabelle2").Range("A2:F500").Clear
Worksheets("Tabelle3").Range("A2:F500").Clear
'
' Sortierung_Durchmesser Makro
' Makro zur Sortierung nach Durchmesser (in Spalte C) und kopieren der kompl. Zeile in Tabellenblatt "Tabelle2".
'
'
Dim shtSrc As Worksheet, shtTarget As Worksheet
Dim rng As Range
Dim strFirst As String, strSearch() As Variant, strSheets() As Variant '# Array-Variablen müssen als Variant deklariert werden

'Suchgbegriffe
strSearch = Array("1.9", "3.0") '# Dezimalstellen werden in VBA durch Punkt getrennt. 3,0 ist mathematisch nicht korrekt.

'Tabellen in der Reihenfolge der Suchbegriffe
strSheets = Array("Tabelle2", "Tabelle3")

Set shtSrc = Sheets("Tabelle1")

With shtSrc
For lngIndex = 0 To UBound(strSearch)
strFirst = ""
Set rng = Nothing
Set shtTarget = Sheets(strSheets(lngIndex))

Set rng = .Range("C:C").Find(What:=strSearch(lngIndex), LookAt:=xlPart, LookIn:=xlValues, MatchCase:=False)

If Not rng Is Nothing Then
strFirst = rng.Address
Do
rng.EntireRow.Copy shtTarget.Cells(shtTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Set rng = .Range("C:C").FindNext(rng)
Loop While Not rng Is Nothing And strFirst rng.Address
End If
Next
End With

Set rng = Nothing
Set shtTarget = Nothing
Set shtSrc = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Scorefun · 25. August 2015

Dann findet er aber auch eine 33,0 ...

mit meinem Vorschlag xlWhole scheint der Code aber gar nichts zu finden...

Office: Zeile kopieren wenn Bedingung (Dezimalzahl) erfüllt.

Zeile kopieren wenn Bedingung (Dezimalzahl) erfüllt.

Zeile kopieren wenn Bedingung (Dezimalzahl) erfüllt.

Zeile kopieren wenn Bedingung (Dezimalzahl) erfüllt.

Zeile kopieren wenn Bedingung (Dezimalzahl) erfüllt. - Similar Threads - Zeile kopieren Bedingung

VBA Zeilen kopieren mit Bedingung

Zeilen kopieren wenn Bedingung erfüllt

Zeile bei Bedingung in anderen Reiter kopieren

Zeilen aufgrund von bestimmten Informationen in anderes Tabellenblatt kopieren

Excel Zeile kopieren und unterhalb einfügen

Zeile in 2. Exceldatei kopieren wenn Bedingung erfüllt ist

Zeilen nach XWert durchsuchen und nMal in Ziel kopieren