Zoeken en vervangen over meerdere werkbladen

[Gorinchem]

Goedemiddag,

In het bijgevoegde voorbeeld, wil ik graag dat bepaalde gegevens van het ene werkblad naar het andere werkblad komen, als de waarden in een cel overeen komen.

Voorbeeld:
Als de waarde in ( Voorblad A4) overeenkomt met een cel in Rittenschema in dit geval A85,
dan moeten de waarden van rij 4 F4 en G4 komen in de cellen van Rittenschema C85 en D85.
Dit moet dan voor het hele werkblad ( Voorblad ) gaan werken.
Onderstaande code heb ik hier gevonden en ben daar zelf mee aan het stoeien gegaan, maar zonder resultaat.
Wie heeft de oplossing voor mij>

Alvast bedankt: Rik

Sub Vervangen()

Dim lRow As Long
lRow = 2
On Error Resume Next
While Worksheets(1).Range("A" & lRow) <> ""
For W = 2 To Worksheets.Count
If Worksheets(W).Cells.Find(Worksheets(1).Range("A" & lRow), LookIn:=xlValues, lookat:=xlWhole) Then
If Not g Is Nothing Then
Worksheets(W).Range(g.Address).Value = Worksheets(1).Range("A" & lRow).Value
Worksheets(W).Range(g.Address).Interior.Color = vbRed
End If
Next
lRow = lRow + 1
Wend

End Sub

 

[VenA]

Plaats svp code tussen codetags voor de leesbaarheid.

Bv

Sub VenA()
Dim f As Range, j As Long, ar
  ar = Sheets("Voorblad").Cells(1).CurrentRegion
  For j = 2 To UBound(ar)
    Set f = Sheets("Rittenschema").Columns(1).SpecialCells(2).Find(ar(j, 1), , xlValues, xlWhole)
      If Not f Is Nothing Then
        With f.Offset(, 2).Resize(, 2)
          .Value = Array(ar(j, 6), ar(j, 7))
          .Interior.Color = vbRed
        End With
      End If
  Next j
End Sub

 

[Gorinchem]

Werkt perfect.

Dank je wel voor de moeite.
Ik zal het op opgelost zetten.

Gr: Rik

 

[Gorinchem]

Goedemiddag,

Ik ben helaas iets te voorbarig geweest.
In het eerste voorbeeld werkt de code van VenA perfect.
Alleen is in het officiële bestand het bereik waarmee gewerkt moet worden, variabel.
De kolom blijft hetzelfde, maar het rijnummer waarmee begonnen moet worden, kan elke keer anders zijn.
Ik dacht dus heel slim te zijn, door "Cells" te veranderen in "Collumn", maar toen kreeg ik fout 13 te zien.
Daarna lopen rommelen met Range.("C2":"H1200") en dergelijke maar natuurlijk ook niet het gewenste resultaat.
Ik heb opnieuw een voorbeeld bijgevoegd, maar nu van het officiële bestand.

Ben ik nog te helpen?

“ Sub Macro1()
Dim f As Range, j As Long, ar
ar = Sheets("Voorblad").Cells(2).CurrentRegion
For j = 2 To UBound(ar)
Set f = Sheets("Rittenschema").Columns(1).SpecialCells(2).Find(ar(j, 1), , xlValues, xlWhole)
If Not f Is Nothing Then
With f.Offset(, 2).Resize(, 2)
.Value = Array(ar(j, 6), ar(j, 7))
.Interior.Color = vbRed

End With
End If
Next j
End Sub”


Alvast bedankt voor de hulp: Rik

 

[Gijsbert1]

zoiets misschien?

Sub VenA()
Dim f As Range, j As Long, ar
  ar = Sheets("Voorblad").[COLOR="#FF0000"][B]Cells(20, 1)[/B][/COLOR].CurrentRegion
  For j = 2 To UBound(ar)
    Set f = Sheets("Rittenschema").Columns(1).SpecialCells(2).Find(ar(j, 1), , xlValues, xlWhole)
      If Not f Is Nothing Then
        With f.Offset(, 2).Resize(, 2)
          .Value = Array(ar(j, 6), ar(j, 7))
          .Interior.Color = vbRed
        End With
      End If
  Next j
End Sub

 

[Gorinchem]

Bij deze code krijg ik ook fout 13

Dim f As Range, j As Long, ar
ar = Sheets("Voorblad").Cells(20, 1).CurrentRegion
For j = 2 To UBound(ar)
Set f = Sheets("Rittenschema").Columns(1).SpecialCells(2).Find(ar(j, 1), , xlValues, xlWhole)
If Not f Is Nothing Then
With f.Offset(, 2).Resize(, 2)
.Value = Array(ar(j, 6), ar(j, 7))
.Interior.Color = vbRed
End With
End If
Next j

De foutmelding krijg ik bij: For j = 2 To UBound(ar) Dit word geel gearceerd.

 

[VenA]

Plaats de code svp tussen codetags. Waarom staat de code niet in het bestand? En waarom stel je hier http://www.helpmij.nl/forum/showthr...n-waarde-van-ene-werkblad-naar-ander-werkblad dezelfde vraag?

Ga in C20 staan en druk op <Ctrl> + A dan kan je zien wat de currentregion is en wat je dus aan moet passen in de code.

 

[Gorinchem]

Dank voor je reactie. Ga proberen of ik hier uit kom.
Sorry voor de dubbele vraag.
Ben redelijk nieuw hier.
Weet nog niet exact hoe alles werkt.

Mvrgr: Rik Gorinchem