drie verschillende loop...do`s combineren tot 1

[jwj1976]

EXCEL/VBA: drie verschillende loop...do`s combineren tot 1

Beste

In onderstaande code wordt gezocht naar offset posities tov Narrative. Deze worden ook netjes onder elkaar geschreven in sheet 2.

Nu heb ik nog 2 identieke macro`s die in hetzelfde document zoeken naar de termen "floc"en "date" en die worden ook naar sheet 2 gekopieerd.

Ik zou ze graag combineren tot 1 macro, maar ik snap niet hoe.
Daarnaast krijg ik het ook niet voor elkaar om de loop te stoppen, zodra hij het document van boven tot beneden heeft doorzocht.

Heeft iemand een idee hoe verder te komen?

Alvast bedankt

Sub narrative()
'
' narrative Macro
'
' Sneltoets: CTRL+y
'
    Cells.Find(What:="narrative", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 2).Range("A1").Select
    Selection.Copy
    Sheets("Blad2").Select
    Cells.Range("A1").Activate
    ActiveSheet.Paste
    ActiveCell.Offset(1, 0).Range("A1").Select
    Sheets("Blad1").Select
    
    Do
    
    Cells.findnext(After:=ActiveCell).Activate
    ActiveCell.Offset(1, 2).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Blad2").Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, 0).Range("A1").Select
    Sheets("Blad1").Select
    
    Loop
    
End Sub

 

[gast0667]

Kan je een voorbeeld bestandje plaatsen ?

 

[jwj1976]

Kan je een voorbeeld bestandje plaatsen ?

Bij deze het voorbeeld bestand. Nu gebruik ik dus 3 macro`s om het voor elkaar te krijgen.

 

[gast0667]

Vervang eens je volledige code door:

Public vAdres1
Public vAdres2
Public vA
Public vB
Public vC
Public vD
Public vCell
Public vFind

Sub narrative()

vA = 1
vB = 2
vC = 1
vD = 2
vCell = "A1"
vFind = "narrative"
FindNext
floc
    
End Sub

Sub floc()

vA = 0
vB = 1
vC = 0
vD = 1
vCell = "C1"
vFind = "floc"
FindNext
fdate
    
End Sub

Sub fdate()

vA = 0
vB = 2
vC = 0
vD = 2
vCell = "B1"
vFind = "data"
FindNext

End Sub

Sub FindNext()

Cells.Find(What:=vFind, After:=ActiveCell, LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
vAdres1 = ActiveCell.Address
ActiveCell.Offset(vC, vD).Range("A1").Select
Selection.Copy
Sheets("Blad2").Select
Cells.Range(vCell).Activate
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Sheets("Blad1").Select
    
Do Until vAdres2 = vAdres1
    Cells.FindNext(After:=ActiveCell).Activate
    vAdres2 = ActiveCell.Address
    If Not vAdres2 = vAdres1 Then
        ActiveCell.Offset(vA, vB).Range("A1").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Blad2").Select
        ActiveSheet.Paste
        ActiveCell.Offset(1, 0).Range("A1").Select
        Sheets("Blad1").Select
        Application.CutCopyMode = False
    End If
Loop

vAdres1 = Empty
vAdres2 = Empty

End Sub

Volgens mij werkt hij zo wel.
Gewoon aanroepen door: ctrl + Y

 

[snb]

Vermijd select en activate in VBA

Sub zoek_en_kopieer()
  For j= 1 to 3
    c0 = sheets("Blad1").cells.find(choose(j,"narrative","floc","date"),,xlvalues).Address
    c1 = c0
    Do
        Range(c1).Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        c1 = Sheets("Blad1").Cells.FindNext(Range(c1)).Address
    Loop Until c1 = c0
  Next
End Sub

 

[jwj1976]

Vermijd select en activate in VBA

Sub zoek_en_kopieer()
  For j= 1 to 3
    c0 = sheets("Blad1").cells.find(choose(j,"narrative","floc","date"),,xlvalues).Address
    c1 = c0
    Do
        Range(c1).Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        c1 = Sheets("Blad1").Cells.FindNext(Range(c1)).Address
    Loop Until c1 = c0
  Next
End Sub

Een sierlijk stukje code vergeleken bij mijn knullige poging. Erg leuk ook om vanuit code terug te werken naar de logica erachter.
Wat ik hier echter in mis, zijn de offset posities tov de gevonden cellen. Nu wordt zeer vaak het zelfde woord gekopieerd.
Tevens worden ze allemaal in dezelfde kolom gekopieerd, terwijl dat eigenlijk A, B en C moeten zijn, maar dat is een probleem wat ik zelf nog wel kan oplossen.

Tevens snap ik niet waarom je Activate en Select zou moeten vermijden.

@Judgepeace: Cells.Range(vCell).Activate geeft een foutmelding tijdens de debug. Tevens is deze stukken trager, doordat alle kolommen doorzocht worden. Eigenlijk hoeven alleen de eerste 20 kolommen doorzocht te worden.

Maar beide heren, zeer bedankt voor de moeite. Het is erg leerzaam allemaal

 

[snb]

Sub zoek_en_kopieer()
  For j= 1 to 3
    c0 = sheets("Blad1").cells.find(choose(j,"narrative","floc","date"),,xlvalues).Address
    c1 = c0
    Do
        Range(c1)[COLOR="Blue"][B].Offset(1,2)[/B][/COLOR].Copy Sheets("Blad2").Cells(Rows.Count, [COLOR="blue"][B]j[/B][/COLOR]).End(xlUp).Offset(1)
        c1 = Sheets("Blad1").Cells.FindNext(Range(c1)).Address
    Loop Until c1 = c0
  Next
End Sub

Het kopiëren naar kolom A,B of C is geïmplementeerd.
Een offset ten opzichte van de gevonden cel is geïmplementeerd.
Volgens mij wordt er niet meer gekopieerd dan het aantal cellen dat een bepaalde tekst bevat.
Je had in je vraag ook geen enkele toelichting bij wat er moet gebeuren. Dat heb ik alleen maar afgeleid uit je code.
Activate en select zijn methoden die te maken heben met de userinterface van Excel.
Om elementen in Excel te kunnen benaderen in VBA zijn deze methoden overbodig.
Programmeren richt zich juist op het achterwege laten van overbodigheden.

 

[jwj1976]

opgelost

Bedankt voor de hulp. Ik kan nu stukken sneller werken met de geboden oplossingen.