---

Jeg har brug for hjælp til at lave en makro, som kan finde og kopiere
data i et ark til et andet ud fra et aftalenummer.

Jeg har to ark. Ark 1 indeholder alle stamdata og i ark 2 indtaster
jeg et aftalenummer. Aftalenummeret skal så trigge makroen til at
finde alle linier i ark 1, der indeholder aftalenummeret (kolonne
A10:???. Nogle af kolonnerne fra de fundne linier, skal så kopieres
over i ark 2, hvor der skal dannes en prismeddelelse.

Håber I forstår og kan komme med lidt vejledning til, hvordan det skal
laves?

---

moso97ad skrev:
> Jeg har brug for hjælp til at lave en makro, som kan finde og kopiere
> data i et ark til et andet ud fra et aftalenummer.
>
> Jeg har to ark. Ark 1 indeholder alle stamdata og i ark 2 indtaster
> jeg et aftalenummer. Aftalenummeret skal så trigge makroen til at
> finde alle linier i ark 1, der indeholder aftalenummeret (kolonne
> A10:???. Nogle af kolonnerne fra de fundne linier, skal så kopieres
> over i ark 2, hvor der skal dannes en prismeddelelse.
>
> Håber I forstår og kan komme med lidt vejledning til, hvordan det skal
> laves?

Hvad er et ark?

---

On 15 Feb., 14:23, Gert Krabsen <fjernkrab...@fjernkrabsenfjern.dk>
wrote:

>
> Hvad er et ark?

Et ark i Excel.
I ark 1 er alle stamdata. I ark 2 har jeg en celle, hvori
aftalenummeret indtastes. Når aftalenummeret er indtastet skal man
kunne trykke på en knap, som så gennemsøger ark 1 for linier, hvori
aftalenummeret findes. De fundne linier skal så automatisk kopieres
til ark 2.

---

Jeg har leget lidt med nedenstående kode. Det eneste jeg gerne vil
have ændret i koden er, at den ikke søger på et forud defineret ord (i
dette eksempel "Significant"). Jeg vil gerne lave en søgning ud fra en
bestemt celle, hvor brugeren kan indtaste et aftalenummer, som både
består af tal og bogstaver:

Sub CopySignificant_click()
'Copy cells of cols A,F,E,D from rows containing "Significant" in
'col D of the active worksheet (source sheet) to cols
'A,B,C,D of Sheet2 (destination sheet)
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1

For sRow = 1 To Range("D65536").End(xlUp).Row
'use pattern matching to find "Significant" anywhere in cell
If Cells(sRow, "D") Like "*Significant*" Then
sCount = sCount + 1
dRow = dRow + 1
'copy cols A,F,E & D
Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
Cells(sRow, "F").Copy Destination:=DestSheet.Cells(dRow, "B")
Cells(sRow, "E").Copy Destination:=DestSheet.Cells(dRow, "C")
Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D")
End If
Next sRow

MsgBox sCount & " Significant rows copied", vbInformation, "Transfer
Done"

End Sub