VBA macro zoeken op waarde en kopieren vorige 10 cellen

Status
Niet open voor verdere reacties.
J

joskjos

Gebruiker
Lid geworden
9 sep 2013
Berichten
94
Hallo,

Ik ben al een tijdje aan het stoeien met excel VBA om een macro te schrijven die het volgende kan:
- zoeken op criteria
- bij gevonden criteria kopieer vorige 10 cellen naar Sheet2
- bij gevonden criteria kopieer volgende 10 cellen naar Sheet2.

De criteria komen in 1 kolom meerdere keren voor en moet dus per gevonden keer alle 10 regels terug en voorwaarts kopieren.

Zie bijgevoegd bestand.

Wie zou mij kunnen helpen. Het moet niet heel moeilijk zijn volgens mij.
 

Bijlagen

Test het maar eens.
Code: 
Sub hsv()
Dim c As Range, tb As Range, firstaddress As String
Set c = Sheets("Blad1").Columns(1).Find("criteria", , xlValues, xlWhole)
 firstaddress = c.Address
   Set tb = c.Offset(-10).Resize(10)
   Set tb = Union(tb, c.Offset(1).Resize(10))
 Do
   Set tb = Union(tb, c.Offset(1).Resize(10), c.Offset(-10).Resize(10))
   Set c = Sheets("Blad1").Columns(1).FindNext(c)
 Loop While Not c Is Nothing And c.Address <> firstaddress
tb.Copy Sheets("Blad2").Cells(1).Offset(1)
End Sub
 
Bedankt Harry!

Het werkt zoals ik had verwacht.

Nu heb ik nog 2 vragen:
- kan je ook de uitkomst in Blad2 per kolom 10 weergeven en dan 1kolom overslaan en weer 10 weergeven?
- Ik zoek ook nog een macro of formule die kan zoeken naar criteria : en dan alles wat na de : staat wordt weergegeven in een cel.

zie het bestand.Bekijk bijlage kopieren data criteria.xlsm

mvgr,
Jos
 
Je tweede vraag moet je nog maar eens iets beter uitleggen Jos.
Code: 
Sub hsv()
Dim c As Range, firstaddress As String, arr, i As Long, n As Long
Set c = Sheets("Blad1").Columns(1).Find("criteria", , xlValues, xlWhole)
     firstaddress = c.Address
     ReDim arr(9, 1)
 Do
  ReDim Preserve arr(9, n + 2)
   For i = 0 To 9
     arr(i, n) = c.Offset(-10 + i)
     arr(i, n + 2) = c.Offset(i + 1)
   Next i
        n = n + 4
   Set c = Sheets("Blad1").Columns(1).FindNext(c)
 Loop While Not c Is Nothing And c.Address <> firstaddress
 Sheets("Blad2").Cells(1, 2).Resize(10, n - 1) = arr
End Sub
 
Wederom bedankt Harry!

Het werkt perfect!

Die 2e vraag is als volgt:

Stel in cel B3 staat de volgende zin: achter deze criteria staat de uitkomst: data 1

Nu wil ik dat er gezocht wordt in kolom B naar het woord: criteria bij het gevonden van criteria de uitkomst na de : moet dan worden getoond in Cel B15.

In cel B15 staat dan: data 1


Mvgr,
Jos
 
Is de naam "criteria" echt het te zoeken woord , of is dit even een verzinsel?
Je zoekt nl. in je eerdere zoektocht ook naar "criteria".

Als het een ander woord dan je eerste zoektocht, wordt het wel eenvoudiger om op te zoeken.

Maar goed, dit is de duurdere versie.
Code: 
Sub hsv()
Dim c As Range, firstaddress As String, arr, i As Long, n As Long
Set c = Sheets("Blad1").Columns(1).Find("criteria", , xlValues, xlWhole)
     firstaddress = c.Address
     ReDim arr(9, 1)
 Do
  ReDim Preserve arr(9, n + 2)
   For i = 0 To 9
     arr(i, n) = c.Offset(-10 + i)
     arr(i, n + 2) = c.Offset(i + 1)
   Next i
        n = n + 4
   Set c = Sheets("Blad1").Columns(1).FindNext(c)
 Loop While Not c Is Nothing And c.Address <> firstaddress
 With Sheets("Blad2")
   .Cells(1, 2).Resize(10, n - 1) = arr
 Set c = Sheets("Blad1").Columns(1).Find("criteria", , xlValues, xlPart)
 If Not c Is Nothing Then
   firstaddress = c.Address
  Do
      If InStr(Sheets("Blad1").Range(c.Address), ":") > 0 Then
        Exit Do
      Else
        Set c = Sheets("Blad1").Columns(1).FindNext(c)
      End If
    Loop While Not c Is Nothing And c.Address <> firstaddress
    .Cells(15, 2) = Trim(Split(c.Value, ":")(UBound(Split(c.Value, ":"))))
   End If
 End With
End Sub
 
Sorry voor wat onduidelijkheid, maar de codes mag je los van elkaar zien en er hoeft niet per definitie gezocht te worden naar criteria.

In Blad2 kolom B mag worden gezocht op een willekeurig woord met als voorbeeld laten we zeggen uitkomst.
Wat dan na de : staat moet komen te staan in cel B15.

zie bestand.Bekijk bijlage kopieren data criteria.xlsm

Achter Blad3 staat ook al een code waar ik mee bezig ben geweest.
Deze code mag je ook ombouwen het volgende wil ik daarmee bereiken:
De bedoeling daarvan is dat een cel wordt verdeelt in meerdere kolommen inclusief de leestekens. De leestekens was ik nog niet helemaal uitgekomen als dat meteen achter een woord staat. (lees/dit/ook) moet dan worden cel1 lees cel 2 / cel3 dit cel4 / cel5 ook.
 
Code: 
Sub hsvtwee()
Dim c As Range, sn
With Sheets("Blad2")
 Set c = .Columns(2).Find("uitkomst", , -4163, 2)
    If Not c Is Nothing Then
      sn = Split(Trim(Split(c.Value, ":")(UBound(Split(c.Value, ":")))), " ")
      .Cells(15, 2).Resize(, UBound(sn) + 1) = sn
    End If
 End With
End Sub
 
Harry,

Bedankt de bovenstaande codes werken allemaal zoals ik had bedoeld! TOP!

Nu heb ik nog iets: het woord criteria op Blad1 word gezocht en dan toont hij de bovenste 10 regels en de onderste 10 regels daarvan. Kan je ook maken dat als criteria gezocht word het maar 1 keer mag voorkomen in de totaal 21 regels? Het komt zoals onderstaande dus 2x voor in de 21 regels maar dan mag hij enkel het eerste gevonden woord criteria gebruiken en niet de 2e binnen de 21 regels.
Ik heb nu bijvoorbeeld in Blad1:

regel 1.
enz.
regel 10.
criteria
regel 11.
regel 12.
criteria.
regel 14.
regel 15.
enz.
regel 20.


Mvgr,
Jos
 
Test het maar eens Jos.
Code: 
Sub hsv()
Dim c As Range, firstaddress As String, arr, i As Long, n As Long, a As Long, b As Long, y As Long
Set c = Sheets("Blad1").Columns(1).Find("criteria", , xlValues, xlWhole)
    firstaddress = c.Address
ReDim arr(9, 1)
 Do
         y = y + 1
         b = c.Row
      If y = 1 Then GoTo begin
      If b - a < 20 Then GoTo einde
begin:
          
    ReDim Preserve arr(9, n + 2)
           For i = 0 To 9
             arr(i, n) = c.Offset(-10 + i)
             arr(i, n + 2) = c.Offset(i + 1)
           Next i
     n = n + 4
     a = c.Row
einde:
        
    Set c = Sheets("Blad1").Columns(1).FindNext(c)
  Loop While Not c Is Nothing And c.Address <> firstaddress
 Sheets("Blad2").Cells(1, 2).Resize(10, n - 1) = arr
End Sub
 
Harry,

De code heb ik weer verwerkt in mijn Excel sheet en het werk prima! Bedankt daarvoor!

Nu heb ik ook de code nodig voor Blad1, maar dan met een zoekwoord dat maar 2x voorkomt in Blad1 kolom 1.
Laten we als zoekwoord nemen: Data
Bij het eerste gevonden woord Data mogen alleen de hele cel waar het woord Data zich in bevind en de onderste 20 cellen daarvan gekopieerd worden naar blad2 kolom 100
Bij het tweede gevonden woord Data mogen alleen de hele cel waar het woord Data zich in bevind en de bovenste 20 cellen daarvan gekopieerd worden naar blad2 kolom 102

Hopelijk kan je me hiermee ook helpen?

Mvgr,
Jos
 
Wat wil je ermee?
Code: 
sub zoekdata()
dim i as long,c as range
with  sheets("blad1").columns(1)
 set c =.find("data")
   for i = 1 to 2
     sheets("blad2").cells(1,iif(i=1,100,100+i)).resize(21) = c.offset(iif(i=1,-20,0)).resize(21).value
     set c = .findnext(c)
  next i
end with
end sub
 
Ik heb nu de volgende code alleen deze geeft een fout: 1004

Sub zoekdata()
Dim i As Long, c As Range
With Sheets("Blad1").Columns(1)
Set c = .Find("data")
For i = 1 To 2
Sheets("Blad2").Cells(1, IIf(i = 1, 2, 1 + i)).Resize(21) = c.Offset(IIf(i = 1, 20, 1)).Resize(21).Value
Sheets("Blad2").Cells(1, IIf(i = 2, 4, 1 + i)).Resize(21) = c.Offset(IIf(i = 2, -20, 0)).Resize(21).Value
Set c = .FindNext(c)
Next i
End With
End Sub

Wat gaat hier fout?
Het eerste zoekwoord data staat op Cel A2
Het tweede zoekwoord data staat iedergeval 50 cellen verder. dus op bijv. A52(dit kan willekeurige cel zijn verder als A52) kan het tweede zoekwoord data staan.
 
Als de eerste gevonden wordt op rij 2, kan je geen 20 cellen omhoog (c.offset(-20)).

Edit:
Ik zal de code aanpassen; ik heb het net andersom gedaan.
 
Laatst bewerkt:
Ik had de code ontworpen vanaf hier, en dan gaat er wel eens wat fout; hierbij moet het goed zijn.

Code: 
sub zoekdata()
dim i as long,c as range
with  sheets("blad1").columns(1)
 set c =.find("data")
   for i = 1 to 2
     sheets("blad2").cells(1,iif(i=1,100,100+i)).resize(21) = c.offset(iif(i=1,0,-20)).resize(21).value
     set c = .findnext(c)
  next i
end with
end sub
 
De tweede zoekterm gaat nog niet goed.
Hierbij mijn code:

Code: 
Sub zoekdata2()
Dim i As Long, c As Range
With Sheets("Blad1").Columns(1)
 Set c = .Find("*data*")
   For i = 1 To 2
     Sheets("Blad2").Cells(1, IIf(i = 1, 100, 1 + i)).Resize(25) = c.Offset(IIf(i = 1, 0, 20)).Resize(25).Value
     Set c = .FindNext(c)
  Next i
End With
End Sub
 
Ik zie een toch iets andere code, zou het daarom misschien fout gaan?
Maak een bestand, dan zien we wel van het hoe en waarom.
Je hoeft niet te zoeken met jokertekens, daar is 'xlpart' voor uitgevonden in de ".find" methode.
 
Laatst bewerkt:
Oke dan, en graag gedaan.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan