Gedeelte gegevens sheet A naar sheet B

[Johan Sluyter]

Probleem is dat macro wel zoekt doorstapt maar niet de gegeven kopieert naar sheet OHW ik blijf in een cirkeltje rondzoeken maar kom er niet uit.

Sub Search()
  
    Dim OpzoekWaarde As String
          
  On Error GoTo Err_Execute
  
    'initialiseren zoekwaarde
        Sheets("OHW").Select
        Range("A:A").Select
        OpzoekWaarde = ActiveCell.Text
        Sheets("A010").Select
        
        Do While OpzoekWaarde <> ""
        
         Sheets("A010").Select
        Range("A:A").Find (OpzoekWaarde)
        'Range("OpzoekWaarde").Find
         
'Als waarde in column A = "projectnr", copieer gedeelte rij naar Sheet
        If ActiveCell.Value = OpzoekWaarde Then
            
'Selecteer gehele rij van active cel in Sheet A010 zet de cursor altijd in kolom E om te copieren
        Range("E" & ActiveCell.Row).Select
'En van daar 5 cellen naar rechts selecteren
        ActiveCell.Range("A1:E1").Select
        Selection.Copy
        Range("A:A").Select
        
'Paste copy row into Sheet OHW
        Sheets("OHW").Select
        ActiveCell.Rows.Select
        Range("J" & ActiveCell.Row).Select
        ActiveSheet.Paste
        Range("A:A").Select
    
    End If

    Sheets("OHW").Select
    ActiveCell.Offset(1, 0).Activate
    OpzoekWaarde = ActiveCell.Text
   
    Loop
    
   
    'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select
    
    MsgBox "Alle data A010 is overgezet naar tabblad OHW."
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred."
   
End Sub

 

[huijb]

Wanneer je een code of formule wil toevoegen, plaats deze dan tussen de code-tags (

 en

) oftewel selecteer je code en klik op het # icoontje. Bij voorbaat dank, zeker ook namens de helpers. Zie ook dit http://www.helpmij.nl/forum/showthread.php?t=321171

 

[Hoornvan]

Johan Sluyter,

Bij mij werkt hij gewoon hoor.
Ik heb er SreenUpdating bij gezet zodat het beeld niet flikkert.
Tevens heb ik even een knop op het blad gezet om de macrode te starten.
Als ik in de Blad A010 in kolom A een cel selecteerd en dan op de knop klikt doet hij wat hij moet doen. (bij mij altans.)

 

[Johan Sluyter]

Beste Wim,
Bedankt voor de snelle reaktie het klopt wat jij ingebouwd hebt en dat werkt bij mij ook maar dit is helaas niet wat ik zocht. Als ik de macro start moet hij beginnen met de waarde in kolom A rij 1 van tabblad OHW , deze opzoeken in kolom A van tabblad A010 en wanneer die beide overeenkomen moet hij een gedeelte van de rij kopieren in tabblad A010 en deze naar tabblad OHW kolom j kopieren daarna doorstappen in tabblad OHW naar volgende rij waarde in kolom A nemen en opzoeken in tabblad A010 weer kopieren enz enz net zolang totdat alle rijen in Tabblad OHW zijn nagezocht. Misschien heb ik je op het verkeerde been gezet met de te korte omschrijving

 

[Hoornvan]

Johan Sluyter,

Ik ben aan het puzzelen en ben er achter gekomen dat hij bij .Find zoekWaarde fout gaat.
Als je de code met F8 door loopt zie je dat hij daarna een stuk overslaat.
Als je op beide bladen het zelfde nummer selecteerd dan doet hij alleen die regel.

Dus hij gaat in de fout bij het zoeken naar het zelfde nummer op A010.
Normaal als je met F8 werkt en je komt 1 regel voorbij Find dan kun je zien dat de gevonden cel is geselecteerd en dat mis ik hier.

Ik ben maar een amateur en denk dan ook dat je hier een specialist nodig heb.

 

[snb]

Het kan met deze code

Sub zoek()
   on error resume next
   sq=sheets("OHW").usedrange
   for j= 1 to ubound(sq)   
      sheets("A010").columns(1).find(sq(j,1)).offset(,5).resize(,5).copy sheets("OHW").cells(j,10)
   next
End Sub

 

[Hoornvan]

snb,

Bedankt voor de code het werkt perfect.

 

[Johan Sluyter]

Beste snb en Wim
Ook dit werkt perfect en is veel simpeler dan ik het als junior had voorgesteld alleen nu kopieert hij de eerste 5 kolommen van A010 naar OHW kolom J terwijl de bedoeling is dat de kolommen E tm I vanaf A010 naar OHW kolom J worden gekopieerd.
Ik ben al van alles gaan proberen om resize(, 5)te vervangen door resize(5, 9) en door Range("E:I") maar dan gaat het helemaal fout zelfs met een gedeelte van mijn eigen code lukt het niet ik voel me dan ook echt een groentje omdat het niet wil lukken.
Toch bedankt voor jullie reakties.
gr.
Johan

 

[snb]

Vorige suggestie aangepast

 

[Johan Sluyter]

Oplossing werkt bedankt

Beste snb

bedankt voor deze oplossing ik was al weer veel te moeilijk aan het zoeken met invoegen en verwijderen kolomen

 Sub zoek()
'invoegen 5 hulpkolommen op OHW
    Columns("J:M").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
      
'vanaf sheet A010 naar OHW
   On Error Resume Next
   sq = Sheets("OHW").UsedRange
   For j = 1 To UBound(sq)
      Sheets("A010").Columns(1).Find(sq(j, 1)).Resize(, 9).Copy Sheets("OHW").Cells(j, 10)
   Next
   
'verwijderen van de 5 hulpkolommen van OHW
    Columns("J:M").Select
    Selection.Delete Shift:=xlToLeft

 

[snb]

Les 1: vermijd select en activate in VBA, want overbodig.
Les 2: meestal heeft Excel ingebouwde faciliteiten die doen wat jij wil; gebruik die in plaats van opnieuw een Excel-wiel uitvinden met VBA (bijv. offset, resize, sort, advancedfilter, autofilter, etc.)