Opgelost Cellen selecteren met bepaalde tekst in cel (vba)

[Albatros]

Hoi,

Ik wil de cellen selecteren in rij10, die in de cel de tekst "deg C" hebben staan, en deze kopiëren naar G2.
(en daarna de cellen selecteren die "F0" in de tekst hebben staan en die kopiëren naar G6)

ik heb een opzetje gemaakt, maar dat werkt helaas niet.
Zie bijlage

Albatros

 

[HansFRAP]

Je kunt gebruik maken van loopje.
Maak een loopje die start in cel: A10 en kijk of de inhoud van die cel: deg C bevat.
Zo ja dan de inhoud kopiëren naar G2. Deze handeling herhalen met de cel B10.
Vraag is dan waar deze inhoud naartoe gekopieerd moet worden.

Sub test()
    Range("A10").Select
    While ActiveCell.Value <> ""
        If InStr(ActiveCell.Value, "deg C") <> 0 Then
            MsgBox "Kopieren"
        End If
        ActiveCell.Offset(0, 1).Select
    Wend
End Sub

 

[sylvester-ponte]

je kan er ook een filter voor gebruien

 

[emields]

zo kan het ook.

 

[AHulpje]

Filter:
In G2:

=FILTER(A10:L10;RECHTS(A10:L10;5)="deg C";"")

In F2:

=FILTER(A10:L10;RECHTS(A10:L10;2)="Fo";"")

 

[Albatros]

Bedankt voor de reacties.
Helaas niet wat ik zoek, maar dat kan aan mijn uitleg liggen uiteraard
De aantal waarden met **deg C en F0 kunnen per meting verschillen.
Wat ik wil is vanaf G2 alle koppen met deg C naast elkaar, en in G6 alle koppen mer F0 naast elkaar.
Ik heb het begaand bijgevoegd met mijn uiteindelijke wens

Albatros

 

[sylvester-ponte]

je kan toch zelf wel de formules van in f2 en g2 zetten? zie post #5

 

[Albatros]

Beste Sylvester. Als iedereen zo'n reactie plaatst kan HM wel opdoeken.
Maar wat ik vraag, wil ik graag, en is een onderdeel van een hele grote makro. Alleen loop ik vast op dit onderdeel.
De formule met =filter heb ik overgenomen, maar krijg hierbij een foutmelding.

Albatros

 

[AHulpje]

Wat voor foutmelding? Is het bereik anders dan A10:L10?

 

[HansFRAP]

Ok, je voorbeeld is helder.
Dan hier de code die je daarvoor kunt gebruiken.

Sub Kopieren()
Dim Startadres As String
    Application.ScreenUpdating = False
    Range("A10").Select
    While ActiveCell.Value <> ""
        Startadres = ActiveCell.Address
        Selection.Copy
        If InStr(ActiveCell.Value, "deg C") <> 0 Then
            Range("G2").Select
            While ActiveCell.Value <> ""
                ActiveCell.Offset(0, 1).Select
            Wend
            ActiveSheet.Paste
        ElseIf InStr(ActiveCell.Value, " Fo") <> 0 Then
            Range("G6").Select
            While ActiveCell.Value <> ""
                ActiveCell.Offset(0, 1).Select
            Wend
            ActiveSheet.Paste
        End If
        Range(Startadres).Select
        ActiveCell.Offset(0, 1).Select
    Wend
    Application.CutCopyMode = False
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

 

[emields]

Dit is zoals je wil, eerst opslaan als xlsm en dan het nieuwe bestand openen.

ps

sylvester-ponte bedoeld alleen maar dat het hier helpmij is en niet maak voor mij.​

 

[AHulpje]

En als je in de oplossing van emields

For Each cl In Range("A10:Z10")

vervangt door

For Each cl In Intersect(ActiveSheet.UsedRange, ActiveSheet.Rows(10))

dan worden alle gevulde cellen in rij 10 verwerkt, ook als je meer dan 26 kolommen hebt gevuld.

 

[HSV]

Sub hsv()
sq = Range("a10:l11")
  sv = Filter(Application.Index(sq, 1), "deg C", -1, 1)
   Range("g3").Resize(, UBound(sv) + 1) = sv
  sv = Filter(Application.Index(sq, 1), "Fo", -1, 1)
   Range("G7").Resize(, UBound(sv) + 1) = sv
End Sub

 

[Albatros]

WOW! wat een scala aan fijne reacties!
@AHulpje, Ik krijg de melding "deze functie is ongeldig". Bij de formules staat de functie Filter er bij mij niet bij. (Office professional plus 2019)

@HansFRAP, Emields, en natuurlijk HSV: super bedankt! Jullie oplossingen werken zoals gewenst! Kan ik verder gaan bouwen aan mijn project.

Albatros