---

Hej

Nogen der ved hvordan man laver en makro der:
1. søger efter et bestemt ord ex. "DATA" som findes flere steder i samme kolonne.
2. Når den finder dette ord "DATA", kopieres cellen ved siden af og sættes ind i et nyt ark.
3. Når den finde flere steder hvor der står "DATA", kopieres cellen ved siden af og sættes under den anden celle fra før.

ex.
A4 inderholder ordet DATA, derfor skal B4 kopieres. (der kunne fe.eks. stå 123456)
B4 kopieres så over i et andet ark. f.eks. Sheet2.B4
A38 inderholder også ordet DATA, så derfor skal B38 kopieres ind (Her kunne stå 654321)
B38 skal så kopieres ind i det andet ark Sheet2.B5, Altså lige nedenuder det andet.

---

Du åbner excel (hvis du har 2007)

Går ind i excel options og sikrer der står et flueben ved "show developer tab in the ribbon".

Nu kan du se developer tab hvor du kan indsætte en knap (ActiveX control Command Button).

Når dette er gjort vises koden for den pågældende knap.

her indsættes følgende kode:
Dim i As Long
Dim j As Long
i = 1
j = 1
Sheet2.Cells.Clear
Do While Sheet1.Cells(i, "A") <> ""
If InStr(1, UCase(Sheet1.Cells(i, "A")), "DATA") > 0 Then
Sheet2.Cells(j, "A") = Sheet1.Cells(i, "B")
j = j + 1
End If
i = i + 1
Loop

Dette sletter alt i ark 2 og indsætter B kollonne fra ark 1 hvis der står DATA i kollonne A.

Du skal bare være sikkert på at der ikke er blanke celler i ark 1 kollonne A, da dette vil få makroen til at stoppe.

Peder

---

Hej

Jeg bruger execl 2010. Jeg har forsøgt at tilføjet som du forskrev og lavet et test ark med nogle test data. Der er dog desværre tomme felter i kolene A.

Jeg har lavet et test ark hvor der ikke er tomme felter:
Sheet1:
A1 = DATA B2=123456
A2 = TEST B3=654987
A3 = TEST B4=TEST

Sheet2 er helt tomt.

Jeg har lavet kanppen på sheet1 og indsatt funktionen du lavede. Men der sker ikke noget når jeg trykker på den. sheet2 er stadig tomt.

---

Hvad med denne:

Private Sub CommandButton1_Click()

Søgeord = InputBox("Indtast søgeord")

If Søgeord <> "" Then
Ark1.Range("A1").Select
Selection.End(xlDown).Select
Sidste_Række = ActiveCell.Row
Selection.End(xlUp).Select


Do While ActiveCell.Row < Sidste_Række
Cells.Find(What:=Søgeord, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Tekst = Ark1.Range("B" & ActiveCell.Row)
Ark2.Activate
Ark2.Range("A1").Select
Kontrol = ActiveCell.Value
Do While Kontrol <> ""
ActiveCell.Offset(1, 0).Select
Kontrol = ActiveCell.Value
Loop
ActiveCell.Value = Tekst
Ark1.Activate
Loop
End If
End Sub


Mvh
CiViC

---

Læste lige, at der var tomme felter i kollonne A, så du får lige denne istedet:

Private Sub CommandButton1_Click()

Søgeord = InputBox("Indtast søgeord")

If Søgeord <> "" Then
Ark1.Range("A65534").Select
Selection.End(xlUp).Select
Sidste_Række = ActiveCell.Row
Ark1.Range("A1").Select


Do While ActiveCell.Row < Sidste_Række
Cells.Find(What:=Søgeord, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Tekst = Ark1.Range("B" & ActiveCell.Row)
Ark2.Activate
Ark2.Range("A1").Select
Kontrol = ActiveCell.Value
Do While Kontrol <> ""
ActiveCell.Offset(1, 0).Select
Kontrol = ActiveCell.Value
Loop
ActiveCell.Value = Tekst
Ark1.Activate
Loop
End If
Ark1.Range("A1").Select
End Sub

Mvh
CiViC

---

Nu må de snart få lavet redigeringsmuligheder på KanDU

Linien:
Sidste_Række = ActiveCell.Row

Skal rettes til:
Sidste_Række = ActiveCell.Row + 1

(Ellers søger den ikke i den sidste linie)

Mvh
CiViC

---

DJfrakja:

Når du har indsat knappen åbnes så et vindue hvor følgende vises?:

Option Explicit

Private Sub CommandButton1_Click()

End Sub

Hvis der gør det skal koden indsættes således:

Private Sub CommandButton1_Click()

Her indsættes koden

End Sub

Er det sådan du har gjort?

---

Øhh fik du det løst?

Dette spørgsmål er blevet annulleret, det er derfor ikke muligt for at tilføje flere kommentarer.