Avatar billede nemlig Professor
05. maj 2009 - 14:00 Der er 10 kommentarer og
1 løsning

Makro til at gøre data fletteklar til Word

Hejsa.

Jeg har et regneark med mange kontaktoplysninger, som står ned i kolonne A

Navn står i celle A5
Adresse står i celle A6
Postnr og by står i celle A7

Næste kontakt står i celle A9,A10,A11 osv.
Nu vil jeg gerne have dataene flyttet, så hver kontakt står i samme række. Dermed bliver dataene fletteklar med Word.
A5 = A2
A6 = B2
A7 = C2
A9 = A3
A10= B3
A11= C3
osv.

Nogen der kan hjælpe med en makro.
Det kan være noget med at jeg flytter markøren til cellen med navn og aktiverer en makro. Så flyttes dataene til næste ledige række....
Og så flytter jeg manuelt til næste celle med navn og aktiverer makroen.

Håber I forstår og har en nem løsning.
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:00 #1
Sub ny()
Dim sidsterække, a As Integer


sidsterække = Range("A65536").End(xlUp).Row
For a = 5 To sidsterække Step 4
    Cells((a + 3) / 4, 1) = Cells(a, 1)
    Cells((a + 3) / 4, 2) = Cells(a + 1, 1)
    Cells((a + 3) / 4, 3) = Cells(a + 2, 1)
Next

End Sub
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:03 #2
For en sikkerheds skyld - sæt de nye værdier over i faneblad 2:

Sub ny()
Dim sidsterække, a As Integer


sidsterække = Range("A65536").End(xlUp).Row
For a = 5 To sidsterække Step 4
    sheets(2).Cells((a + 3) / 4, 1) = sheets(1).Cells(a, 1)
    sheets(2).Cells((a + 3) / 4, 2) = sheets(1).Cells(a + 1, 1)
    sheets(2).Cells((a + 3) / 4, 3) = sheets(1).Cells(a + 2, 1)
Next

End Sub
Avatar billede nemlig Professor
05. maj 2009 - 15:18 #3
Ser interessant ud.
Jeg har desværre informeret lidt forkert.
I stedet for 3 rækker pr. kontaktperson, er der altså tale om 4 rækker.
Jeg har leget lidt med det, men det står helt forkert.
Kan du hjælpe.... :)
Avatar billede nemlig Professor
05. maj 2009 - 15:19 #4
Jeg har prøvet sådan her:

Sub ny()
Dim sidsterække, a As Integer


sidsterække = Range("A65536").End(xlUp).Row
For a = 6 To sidsterække Step 5
    Sheets(2).Cells((a + 4) / 5, 1) = Sheets(1).Cells(a, 1)
    Sheets(2).Cells((a + 4) / 5, 2) = Sheets(1).Cells(a + 1, 1)
    Sheets(2).Cells((a + 4) / 5, 3) = Sheets(1).Cells(a + 2, 1)
    Sheets(2).Cells((a + 4) / 5, 4) = Sheets(1).Cells(a + 3, 1)
Next

End Sub
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:22 #5
Er der stadig et mellemrum mellem kontaktpersonerne, så næste kontaktperson starter i A10?
Avatar billede nemlig Professor
05. maj 2009 - 15:23 #6
Ja - præcis
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:25 #7
Skriv helt præcis, hvor først navn, adresse, postnr, by står? Og hvor næste står?
Avatar billede nemlig Professor
05. maj 2009 - 15:28 #8
Jeg fik det til at virke med ovenstående kode. Jeg skulle bare lige rette et enkelt tal.
Mange tak for indsatsen.
Det gjorde mit arbejde betydeligt nemmere.
Mange tak.
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:29 #9
Så er den der:-)

Sub ny()
Dim sidsterække, a As Integer


sidsterække = Sheets(1).Range("A65536").End(xlUp).Row
For a = 5 To sidsterække Step 5
    Sheets(2).Cells((a + 5) / 5, 1) = Sheets(1).Cells(a + 0, 1)
    Sheets(2).Cells((a + 5) / 5, 2) = Sheets(1).Cells(a + 1, 1)
    Sheets(2).Cells((a + 5) / 5, 3) = Sheets(1).Cells(a + 2, 1)
    Sheets(2).Cells((a + 5) / 5, 4) = Sheets(1).Cells(a + 3, 1)
Next

End Sub
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:30 #10
to tal, vel...
Avatar billede jonasboege Praktikant
05. maj 2009 - 15:31 #11
Velbekomme :-)
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Excel kurser for alle niveauer og behov – find det kursus, der passer til dig

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester

IT-JOB

Netcompany A/S

Linux Operations Engineer

IT-Universitetet i København

CIO

Forsvarsministeriets Materiel- og Indkøbsstyrelse

Ingeniør til Satellitkommunikation