Opgelost VBA als een deel waarde voorkomt in een cel, gegevens kopiëren naar een ander tabblad

[skystormer]

Hallo,

Hopende dat iemand mij kan helpen in deze.
Ik probeer een macro te vinden/maken indien in tabblad Import in kolom A de waarde "1" voorkomt de eerste 5 kolommen van deze rij naar het tabblad controle worden gekopieerd.

Dus een waarde 1 wordt gekopieerd, maar ook de celwaarde 1.2. (bevat ook de waarde 1)
Hopende dat iemand de kennis heeft voor deze.

Dank voor het proberen in ieder geval.

 

[edmoor]

Zoiets?

 

[emields]

of zo.

 

[HSV]

Of simpel.

 

[peter59]

Of m.b.v. power query dus geen macro benodigd.

 

[skystormer]

Dank jullie wel.
Precies wat ik zocht.
@ Edmoor, dank voor de snelle input, deze ga ik niet nemen. Ik zie dat wanneer er 1 cel zou zijn waar de gegevens leeg zouden zijn en vervolgens de volgende rij wel weer, dan eindigt de zoekfunctie.
Met die van emields en HSL wordt dit wel afgedekt.
peter59, dank je voor het wijzen naar de power queries.
Deze ga ik me ook in verdiepen voor 1 van de andere zaken welke ik met die bestand wil gaan doen.
Namelijk een data dump welke elke dag ververst in om daar gegevens op te halen (had eerste in gedachten om deze mbv een macro de gegevens op te halen en hier in te plaatsen. (ander tabblad dan weer)

 

[Obrecht]

Ik zag dat bij de macro's van HSL en emiels de cellen dubbel gekopieerd worden als je vaker op de knop drukt.

in deze aangepaste code van emiels zit een controle op de kleur van de gekopieerde regels.
Deze krijgen een rode kleur. Nu kun je aanpassingen doen en kopiëren zonder dat gekopieerde regels opnieuw worden gekopieerd.

Sub KopieerEnMarkeerCellen()
    Dim cl As Range
    For Each cl In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
        If InStr(cl.Value, "1") Then
            ' Controleer of de tekstkleur al rood is (RGB waarde van rood is 255, 0, 0)
            If cl.Font.Color <> RGB(255, 0, 0) Then
                With Sheets("Controle")
                    cl.Resize(, 5).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
                End With
                ' Verander de tekstkleur naar rood
                cl.Font.Color = RGB(255, 0, 0)
            End If
        End If
    Next
End Sub

 

[HSV]

RemoveDuplicates:

Private Sub CommandButton1_Click()
 With Sheets("import").Cells(1).CurrentRegion.Offset(1).Resize(, 5)
  .AutoFilter 1, "*1*"
  .Copy Sheets("controle").Cells(Rows.Count, "A").End(3)(2)
  .AutoFilter
  Sheets("controle").Cells(1).CurrentRegion.RemoveDuplicates Array(1, 2, 3, 4, 5), 1
 End With
End Sub