• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

cellen vergelijken en bij match andere cellen kopiëren

Status
Niet open voor verdere reacties.
C

Cranky

Gebruiker
Lid geworden
3 mrt 2008
Berichten
38
Ok, ik heb een lastige. Ik heb twee werkbladen;

Op Blad1 twee kolommen met productnamen en twee kolommen met aantallen (allebei met hetzelfde doel, maar naast elkaar past er meer op een pagina).
Op Blad2 een kolom met productnamen en een kolom met aantallen.

Op beide bladen staan dezelfde producten, maar niet in dezelfde volgorde.

Nu wil ik graag een macro maken die de aantallen overneemt van het ene naar het andere werkblad.

Dus zoiets als: als een cel in kolom A op Blad1 dezelfde waarde heeft als een cel in kolom A op Blad2: kopieer dan de waarde van een andere cel in dezelfde rij op Blad1 naar een cel in Blad 2.
(Knap staaltje programmeerwerk he? :p)

Ik heb wat geprobeerd met de code om lege rijen te verwijderen elders op dit forum, maar ik kom er niet uit. Hopelijk heeft iemand een gemakkelijke manier.
 
Als jij een voorbeeldbestandje post (zonder gevoelige info) dat duidelijk maakt wat je hebt en waar je heen wil kunnen wij je zeker helpen
 
Ok, de bijlage hoort een sjabloon te zijn (.xlt), maar dit forum pikt dat niet.

Zoals je ziet heb ik al enkele cellen op tabblad Bestelling laten verwijzen naar cellen op tabblad Norm. Dit wil ik graag automatiseren. De productnamen op tabblad Norm zijn exact hetzelfde als op tabblad Bestelling, dus dat zou moeten lukken toch?
 

Bijlagen

  • Jumbo bestellijst nieuw.xls
    97,5 KB · Weergaven: 208
Probeerseltje:
Code: 
Sub DoorvoerenBestellijst()
    For i = Worksheets("Bestelling").Cells(Rows.Count).End(xlUp).Row To 1 Step -1
    If Worksheets("Norm").Cells(i, 1).Value = Worksheets("Bestelling").Cells(i, 1).Value Then Worksheets("Bestelling").Cells(i, 4).FormulaR1C1 = "=Norm!" + Worksheets("Norm").Cells(i, 5)
    If Worksheets("Norm").Cells(i, 7).Value = Worksheets("Bestelling").Cells(i, 1).Value Then Worksheets("Bestelling").Cells(i, 4).FormulaR1C1 = "=Norm!" + Worksheets("Norm").Cells(i, 10)
    Next i
End Sub
Werkt helaas niet. Wat doe ik verkeerd?
 
Laatst bewerkt:
Code: 
Sub tst()
On Error Resume Next
With Sheets("Bestelling")
    .Range("D18:D" & Sheets("Bestelling").Cells(Rows.Count, 4) _
                .End(xlUp).Row).ClearContents
    For Each cl In .Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1) _
                .End(xlUp).Row)
        With Sheets("Norm").UsedRange
            .Find(cl.Value, , xlValues, xlWhole).Offset(, 3).Copy cl.Offset(, 3)
        End With
    Next
End With
End Sub
 
Laatst bewerkt:
Code: 
Sub tst()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .offset(,3).ClearContents
    For Each cl In .cells
      Sheets("Norm").UsedRange.Find(cl.Value, , xlValues, xlWhole).Offset(, 3)= cl.Offset(, 3).value
    Next
  End With
End Sub
 
Laatst bewerkt:
Warme bakkertje zei:
Code: 
Sub tst()
On Error Resume Next
With Sheets("Bestelling")
    .Range("D18:D" & Sheets("Bestelling").Cells(Rows.Count, 4) _
                .End(xlUp).Row).ClearContents
    For Each cl In .Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1) _
                .End(xlUp).Row)
        With Sheets("Norm").UsedRange
            .Find(cl.Value, , xlValues, xlWhole).Offset(, 3).Copy cl.Offset(, 3)
        End With
    Next
End With
End Sub
Klik om te vergroten...

Hey, deze werkt meteen! Super, bedankt! Alleen, ik wil graag de formule kopiëren en niet de waarde van de cel. Dan hoef ik de macro alleen uit te voeren als ik wat verander aan de bestellijst en worden de aantallen ook doorgevoerd als de sheet zonder macro's wordt uitgevoerd. Het wil niet lukken met .Copy cl.Formula . Ideeën?
 
snb zei:
Code: 
Sub tst()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .offset(,3).ClearContents
    For Each cl In .cells
      Sheets("Norm").UsedRange.Find(cl.Value, , xlValues, xlWhole).Offset(, 3)= cl.Offset(, 3)
    Next
  End With
End Sub
Klik om te vergroten...

Bedankt voor je reactie maar dit lijkt niet te werken. Helaas begrijp ik de code ook niet helemaal (ik doe mijn best) dus mogelijk moet ik er nog iets aan veranderen om het te kunnen inpassen in mijn project.
 
Code: 
Sub tst()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .offset(,3).ClearContents
    For Each cl In .cells
      Sheets("Norm").UsedRange.Find(cl.Value, , xlValues, xlWhole).Offset(, 3)= cl.Offset(, 3).[COLOR="Red"]formula[/COLOR]
    Next
  End With
End Sub
 
Waarom formules plaatsen. Activeer de macro automatisch als je tabblad bestelling activeert (selecteert)Zet de code achter tabblad bestelling (rechtsklikken tab werkblad Bestelling >> Programmacode weergeven selecteren >> Code plakken)
Code: 
Private Sub Worksheet_Activate()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).ClearContents
    For Each cl In .Cells
    x = Sheets("Norm").UsedRange.Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Value
      cl.Offset(, 3) = IIf(x > 0, x, "")
    Next
  End With
End Sub
Telkens je nu iets wijzigt in werkblad Norm en je gaat kijken naar je bestellijst wordt deze automatisch aangepast. En of je nu de macro telkens draait of je verlaat even blad bestelling na een wijziging in dat blad maakt toch weinig verschil, denk ik.

Wil je toch echt formules plaatsen
Code: 
Sub tst()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).ClearContents
    For Each cl In .Cells
      cl.Offset(, 3).Formula = IIf(cl.Value <> "", "=Norm!" & Sheets("Norm").UsedRange _
            .Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Address, "")
    Next
  End With
End Sub

Om je lege regels te verbergen
Code: 
Sub tst2()
With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
End With
End Sub
 
Laatst bewerkt:
Warme bakkertje zei:
Waarom formules plaatsen. Activeer de macro automatisch als je tabblad bestelling activeert (selecteert)Zet de code achter tabblad bestelling (rechtsklikken tab werkblad Bestelling >> Programmacode weergeven selecteren >> Code plakken)
(CODE)
Telkens je nu iets wijzigt in werkblad Norm en je gaat kijken naar je bestellijst wordt deze automatisch aangepast. En of je nu de macro telkens draait of je verlaat even blad bestelling na een wijziging in dat blad maakt toch weinig verschil, denk ik.
Klik om te vergroten...
Omdat ik er zeker van wil zijn dat het ook werkt als het bestand wordt uitgevoerd zonder macro's (beveiliging).

Maar misschien moet ik daar toch nog maar eens over nadenken want dit is wel erg handig, bedankt! Ik zou de code dan trouwens niet achter het werkblad Bestelling zetten, maar in Workbook_BeforeClose.

Wil je toch echt formules plaatsen
Code: 
Sub tst()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).ClearContents
    For Each cl In .Cells
      cl.Offset(, 3).Formula = IIf(cl.Value <> "", "=Norm!" & Sheets("Norm").UsedRange _
            .Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Address, "")
    Next
  End With
End Sub
Klik om te vergroten...
Helemaal super, bedankt! :D

Om je lege regels te verbergen
Code: 
Sub tst2()
With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
End With
End Sub
Klik om te vergroten...
Zelfs daaraan heb je gedacht. :) Maar die had ik al van je overgenomen met hulp van Hoornvan. Niet om lege rijen te verbergen maar om rijen te verbergen waarin het te bestellen aantal 0 is. http://www.helpmij.nl/forum/showthread.php?t=513676
Nu had ik hierbij alle producten handmatig op 0 gezet. De kolom Aantal in rijen die niet verwijderd moeten worden op werkblad Bestelling (de koppen zoals Fruit en groenten, Soep etc.) heb ik leeg gelaten. Met If Not Cells(i, 4).Value = "" kon ik daarvoor zorgen.

Helaas gooit dit stukje roet in het eten: .Offset(, 3).ClearContents

Hoe zou ik dat een kunnen aanpakken?
 
Nog zoiets...

De cellen worden natuurlijk alleen gekoppeld als de productnamen exact hetzelfde zijn (case sensitive ook nog).

Ik zou graag de producten op het werkblad Norm die niet voorkomen op het werkblad Bestelling opsporen en in een MsgBox weergeven.

Wie o wie... ;)
 
Laatst bewerkt:
Aanvulling
Code: 
Private Sub Worksheet_Activate()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).ClearContents
    For Each cl In .Cells
    x = Sheets("Norm").UsedRange.Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Value
      cl.Offset(, 3) = IIf(x > 0, x, "")
   [COLOR="Red"] x = ""[/COLOR]
    Next
  End With
End Sub
 
Warme bakkertje zei:
Aanvulling
Code: 
Private Sub Worksheet_Activate()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).ClearContents
    For Each cl In .Cells
    x = Sheets("Norm").UsedRange.Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Value
      cl.Offset(, 3) = IIf(x > 0, x, "")
   [COLOR="Red"] x = ""[/COLOR]
    Next
  End With
End Sub
Klik om te vergroten...

Wat doet deze aanvulling? Sorry, ik zie het niet.
 
De aanvulling zorgt ervoor dat je de juiste resultaten op je bestellingblad krijgt :p
 
Hey waarom is dit topic verplaatst?

Bedankt Warme Bakkertje, maar was dat niet al zo dan? Ik probeer de code te begrijpen.

Ik heb besloten om toch te gaan voor de formule en niet voor de waarde. Klopt jouw code voor het invullen van de formules wel nog dan?

Wil iemand ook even voor me kijken naar dit stukje alsjeblieft? http://www.helpmij.nl/forum/showthread.php?t=513676 De nieuwe code om de formules over te nemen van het ene naar het andere werkblad wist mijn handmatig ingevoerde nullen in de rij aantal, waardoor die rijen niet meer verwijderd worden. Ik weet even niet hoe ik de code van Warme Bakkertje zo kan aanpassen dat de nullen die er al in staan (nu wel waarden en geen formules dus) gespaard worden.

En ik zou graag een manier vinden om deproductnamen op te sommen die op het werkblad Norm wel voorkomen maar niet op het werkblad Bestelling.
 
Ik heb dat van die witregels als volgt opgelost:

Code: 
Function HideOngebruikt()
ThisWorkbook.Worksheets("Bestelling").Unprotect
  
  With Sheets("Bestelling").Columns("A:A")
    For i = .Cells(Rows.Count).End(xlUp).Row To 1 Step -1
    If Not Cells(i, 1).Font.Bold = True Then If Not Cells(i, 1).Value = "" Then If Cells(i, 4).Value <= 0 Then Cells(i, 4).EntireRow.Hidden = True
    Next i
  End With

ThisWorkbook.Worksheets("Bestelling").Protect
End Function

Hoe kan ik ervoor zorgen dat het verbergen van rijen pas vanaf rij 18 begint?
 
Test
Code: 
Sub Formules()
    On Error Resume Next
    With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
        For Each cl In .Cells
            If cl.Value <> "" And cl.Offset(, 3) <> 0 Then
                cl.Offset(, 3).Formula = "=Norm!" & Sheets("Norm").UsedRange _
                    .Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Address
            End If
        Next
    End With
End Sub

Sub HideOngebruikt()
    With Sheets("Bestelling")
        .Unprotect
        For Each cl In .Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row) 
            If Not cl.Font.Bold = True And cl.Value <> "" And cl.Offset(, 3).Value <= 0 Then
                cl.EntireRow.Hidden = True
            End If
        Next
        .Protect
    End With
End Sub
 
De Sub Formules werkt niet. Maar zoals het nu is doet 'ie het ook goed?

Code: 
Function DoorvoerenAantal()
  On Error Resume Next
  With Sheets("Bestelling").Range("A18:A" & Sheets("Bestelling").Cells(Rows.Count, 1).End(xlUp).Row)
    .Offset(, 3).ClearContents
    For Each cl In .Cells
      cl.Offset(, 3).Formula = IIf(cl.Value <> "", "=Norm!" & Sheets("Norm").UsedRange _
            .Find(cl.Value, , xlValues, xlWhole).Offset(, 4).Address, "")
    Next
  End With
End Function

HideOngebruikt doet het wel! Geweldig bedankt. Ik wilde al een trucje gaan toepassen door de rijen die niet verborgen moeten worden een ander lettertype te geven. Maar dit is veel mooier!

Ik ga dit topic op opgelost zetten en de vraag over het opsnorren van productnamen die niet op beide werkbladen voorkomen opnieuw posten, want die vraag is toch ook off-topic.

Bedankt voor je hulp, het wordt mooi zo.

Ps: Je gebruikt liever Subs dan Functions?
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan