Makro til at finde og overføre data

send til
tommybak@netscape.net
hvis det ikke er for stort :-)

Har du tænkt på at bruge Avanceret filter (evt optag en makro).
Den butrde sagtens kunne gøre det....

butrde = burde

Det kan gøres med funktionen DHENT

Glem lige mit svar. DHENT duer ikke, og jeg kan ikke finde det gode eksempel jeg engang havde.

En makro, der skulle gøre det

Sub FindOrd()
Dim Fundet() As Integer, OK As Boolean
I = 1
On Error GoTo Slut
ReDim Fundet(1)
    Søg = Range("K3")
      Columns("A:H").Select 'området den søger på ret det selv til, her kolonne A til H
      Selection.Find(What:=Søg, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
        A = ActiveCell.Row
        B = ActiveCell.Column
        Færdig = Cells(A, B).Address
        Cells(A, B).Activate
        Fundet(I) = ActiveCell.Row
      I = I + 1
    Do
    ReDim Preserve Fundet(I)
      Cells.FindNext(After:=ActiveCell).Activate
        A = ActiveCell.Row
        B = ActiveCell.Column
        Cells(A, B).Activate
      If Cells(A, B).Address = Færdig Then Exit Do
        Fundet(I) = ActiveCell.Row
      I = I + 1
  Loop
Videre:

Slut:
  'Ret nedenstående til dit arknavn og kolonner
  ' du kan også lave om så det gemmer på samme ark
  For t = 1 To I - 1
  rk = Sheets("Ark2").Range("B65536").End(xlUp).Offset(1, 0).Row
  Sheets("Ark2").Range("A" & rk) = Range("A" & Fundet(t))
  Sheets("Ark2").Range("B" & rk) = Range("B" & Fundet(t))
  Sheets("Ark2").Range("C" & rk) = Range("G" & Fundet(t))
     
Next

End Sub

Testark sendt (det fylder 20kb).

Hej kabbak, jeg så ikke lige din kommentar inden jeg fik sendt ovenstående.
Det ser spændende ud, så jeg afprøver lige makroen.

kabbak, du er inde på noget af det rigtige, men den fungere ikke helt.
Den medtager data der ikke opfylder kravet i indtastningsfeltet, og ved en af testene skriver den de første tre poster 2 gange.
Jeg har prøvet at ændre MatchCase til True, men det hjalp ikke.
Jeg kan ikke lige gennemskue, hvor den evt. laver fejlen.

Ok har rettet lidt

Sub FindOrd()
Dim Fundet() As Integer, OK As Boolean
I = 1
On Error GoTo Slut
ReDim Fundet(1)
    Søg = Range("K3")
      Columns("A:H").Select 'området den søger på ret det selv til, her kolonne A til H
      Selection.Find(What:=Søg, After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
        A = ActiveCell.Row
        B = ActiveCell.Column
        Færdig = Cells(A, B).Address
        Cells(A, B).Activate
        Fundet(I) = ActiveCell.Row
              If I > 1 Then
        For t = 1 To I - 1
          If Fundet(I) = Fundet(t) Then
          I = I - 1
        End If
        Next
      End If
      I = I + 1

    Do
    ReDim Preserve Fundet(I)
      Cells.FindNext(After:=ActiveCell).Activate
        A = ActiveCell.Row
        B = ActiveCell.Column
        Cells(A, B).Activate
      If Cells(A, B).Address = Færdig Then Exit Do
        Fundet(I) = ActiveCell.Row
              If I > 1 Then
        For t = 1 To I - 1
          If Fundet(I) = Fundet(t) Then
          I = I - 1
        End If
        Next
      End If
      I = I + 1
  Loop
Videre:

Slut:
  'Ret nedenstående til dit arknavn og kolonner
  ' du kan også lave om så det gemmer på samme ark
  For t = 1 To I - 1
  rk = Sheets("Ark2").Range("B65536").End(xlUp).Offset(1, 0).Row
  Sheets("Ark2").Range("A" & rk) = Range("A" & Fundet(t))
  Sheets("Ark2").Range("B" & rk) = Range("B" & Fundet(t))
  Sheets("Ark2").Range("C" & rk) = Range("G" & Fundet(t))
     
Next

End Sub

Den medtager stadig mere end kravet.
Ved en søgning hvor der findes 2 poster medtager den 1 der ikke opfylder kravet, og ved en søgning  hvor der findes 9 poster medtager den 6 ekstra.
De ekstra poster, der har lavere rækkenummer end det søgte, placeres efter det, der opfylder kravet ved overførslen til ark2.

Undskyld, jeg glemte at nævne, at den ikke længere skriver posterne 2 gange, så det er fikset.

Har du husket at slætte data på ark 2 inden du kører makroen

den søger i alle celler i Columns("A:H"), måske skal den kun søge i en kolonne, så skal du rette io denne linie.

  Columns("A:H").Select 'området den søger på ret det selv til, her kolonne A til H
      Selection.Find(What:=Søg, After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate

Ja, hele ark 2 er ryddet inden makroen kører, og jeg har prøvet at rette makroen så den kun søger i kolonne B, men den medtager stadig poster der ikke opfylder søgekravet.
Jeg kan evt. sende arket inklusive din imponerende makro, hvis det kan hjælpe til forståelsen.

det må du gerne sendtil#kabbak@tiscali.dk

fjern sendtil#

ark sendt retur.
Jeg har gjort overførslen meget enkel
Date er navngivet database, indtastningsområdet er navngivet Indtastning og resultatområdet - > output.
Disse områder kan sagtens befinde sig på forskellige ark.
Det, der står som overskrift i output-området er det som overføres.
Det, som står som overskrift i Indtastning er det der søges efter.

Sub Transfer
[database].AdvancedFilter xlFilterCopy, [Indtastning], [output], True
End Sub

Stopper lige mit abonnement på dette spørgsmål - i spammer jo min mailbox *gg*

:-)

-> bak
Det ser jo ikke så imponerende ud som kabbak's makro, men det ser ud til at virke.
Men hvad sker der, hvis området der hedder database udvides?
Det vil nemlig ske løbende.

-> kabbak
Hvis jeg følger makroen trin for trin, ser det ud til, at den første post den finder, der opfylder kravet, sættes = Færdig, hvorefter den gennemløber resten af kolonnen.
Når den når til den sidste post, begynder den forfra i kolonnen, indtil den når den række der blev sat = Færdig.
Burde makroen ikke stoppe, når den når til sidste post/celle i kolonnen?

Nå, men det er ved at være ved den tid, hvor jeg stopper for i dag, jeg vender frygtelig tilbage i morgen  ;o)

Det er jeg da ked af. Jeg ville da gerne lave en imponerende makro :-)

Du definere da bare databasen dynamisk.
Indsæt dette under navnet database
=FORSKYDNING(Ark1!$A$1;0;0;TÆLV(Ark1!$A$1:$A$1000);8)

eller vælg hele kolonne A:H og navngiv det database.

Ok

Sub FindOrd()
Dim Fundet() As Integer, OK As Boolean
I = 1
On Error GoTo Slut
ReDim Fundet(1)
    Søg = Range("K3")
      Columns("B:B").Select 'området den søger på ret det selv til, her kolonne A til H
      Selection.Find(What:=Søg, After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        True).Activate
        Færdig = ActiveCell.Address
        A = ActiveCell.Row
        Færdig = A
        B = ActiveCell.Column
     
        Cells(A, B).Activate
        Fundet(I) = ActiveCell.Row
              If I > 1 Then
        For T = 1 To I - 1
          If Fundet(I) = Fundet(T) Then
          I = I - 1
        End If
        Next
      End If
      I = I + 1

    Do
    ReDim Preserve Fundet(I)
      Cells.FindNext(After:=ActiveCell).Activate
        A = ActiveCell.Row
          If A <= Færdig Then Exit Do
        B = ActiveCell.Column
        Cells(A, B).Activate
   
        Fundet(I) = ActiveCell.Row
              If I > 1 Then
        For T = 1 To I - 1
          If Fundet(I) = Fundet(T) Then
          I = I - 1
        End If
        Next
      End If
      I = I + 1
  Loop
Videre:

Slut:
  'Ret nedenstående til dit arknavn og kolonner
  ' du kan også lave om så det gemmer på samme ark

  For T = 1 To I
  If Fundet(T) <> 0 Then
    rk = Sheets("Ark2").Range("B65536").End(xlUp).Offset(1, 0).Row
  Sheets("Ark2").Range("A" & rk) = Range("A" & Fundet(T))
  Sheets("Ark2").Range("B" & rk) = Range("B" & Fundet(T))
  Sheets("Ark2").Range("C" & rk) = Range("G" & Fundet(T))
End If
Next

End Sub

-> bak
Det med at navngive hele kolonneområdet faldt mig ind, lige før jeg faldt i søvn - man tænker ikke så hurtigt sidst på dagen :o)
Men det virker som det skal.

-> kabbak
Nu virker din makro også perfekt.
Nu vil jeg se lidt nærmere på den for at se, hvordan den virker, og se om jeg kan lære lidt mere VBA  :o)

Hvis de to eksperter så lige vil smide et svar, så kan jeg få delt pointene ud.
Mange tak for hjælpen.

Et svar. ;-))

endnu et :-)

Pokkers, det glippede igen .......

:o)

tak for point. ;-))

og tak herfra. Denne gang har jeg da heldigvis ikke flere valgmuligheder :-)