Avatar billede barentsen Novice
03. juni 2008 - 22:17 Der er 8 kommentarer og
2 løsninger

VBA kode

Hej Eksperter

Er der nogen der kan hjælpe med at lave en vba-kode der kan løse følgende opgave for mig: (Dumt spørgsmål, det ved jeg jo der er, men er der nogle der vil lave koden?)

Jeg har et ark hvor der kun står noget i række 1. Til gengæld er det ikke givet, hvor mange kolonner der er data i - men første gang der er en kolonne uden data, så kommer der ikke flere data.

Hver anden kolonne indeholder et navn (A1, C1, E1 osv.)
Hver anden kolonne indeholder et tal tilhørende navnet fra kolonnen lige før (B1, D1, F1 osv.) (dvs. A1 og B1 hører sammen, C1 og D1 hører sammen osv.)

Opgaven er så, vha. vba-kode, at sætte dataene under hinanden så, A1 indeholder navn, og B1 indeholder det tilhørende tal.
A2 indeholder næste navn, og B2 det tilhørende tal, osv. hele vejen ned.

Dataene skal oprettes i et nyt ark.
Hvis vba-koden også kan sørge for at dataene bliver sorteret efter tallets størelse, og med det højeste øverst, så er det rigtig godt, men ellers er det jo ikke noget problem selv at sortere efterfølgende.

Ekstraopgave, som kun skal løses hvis du lyster (behøves altså ikke for at gøre sig fortjent til alle pointene):
I det nye ark skal Felt A1 = "Pladsering", B1 = "Navn" , C1 = "Point".
A2 = "1", A3 = "2", A4 = "3" osv.
Dataene fra mit ark skal så i stedet stå i felterne B2, C2 og nedefter.
Dvs. resultatet af koden skal gøre, at der er en liste inkl. overskrifter, der viser pladsering, navn og point på samtlige fra min liste der bare er i række 1.

Superopgaven, der kan give ekstra point:
Hvis flere navne har samme antal point, så skal de alle have samme pladsering, men den næste skal så have en pladsering dårligere:
Ex. hvis der er 3 navne der har 12 point og det svarer til en 5. plads, så skal der stå 5 ud for hver af deres navne, men næste navn i listen med ex. 11 point skal så have 8 stående i pladsering.

God fornøjelse, for dem der kan lide den slags opgaver.

På forhånd mange tak for eksperthjælpen.
Avatar billede kabbak Professor
03. juni 2008 - 22:45 #1
her er starten

Public Sub FlytTilArk()
    Dim Fra_ark As Worksheet, Til_ark As Worksheet, I As Integer
    Set Fra_ark = Worksheets("Ark1")
    Set Til_ark = Worksheets("Ark2")
    Til_ark.Cells.ClearContents
    Til_ark.Range("A1") = "Placering"
    Til_ark.Range("B1") = "Navn"
    Til_ark.Range("C1") = "Point"
    For I = 1 To 200 Step 2
        If Fra_ark.Cells(65536, I + 1).End(xlUp).Row = 1 Then Exit For
        Fra_ark.Range(Fra_ark.Cells(1, I), Fra_ark.Cells(65536, I + 1).End(xlUp)).Copy _
                Til_ark.Cells(65536, 2).End(xlUp).Offset(1, 0)
    Next
    Til_ark.Activate
    Range("B3").Select
    Application.CutCopyMode = False
    Range("A1:C" & Cells(65536, 2).End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlDescending, Header:= _
                                                      xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                                      DataOption1:=xlSortNormal

End Sub
Avatar billede kabbak Professor
03. juni 2008 - 22:51 #2
her med placering

Public Sub FlytTilArk()
    Dim Fra_ark As Worksheet, Til_ark As Worksheet, I As Integer, C As Range
    Set Fra_ark = Worksheets("Ark1")
    Set Til_ark = Worksheets("Ark2")
    Til_ark.Cells.ClearContents
    Til_ark.Range("A1") = "Placering"
    Til_ark.Range("B1") = "Navn"
    Til_ark.Range("C1") = "Point"
    For I = 1 To 200 Step 2
        If Fra_ark.Cells(65536, I + 1).End(xlUp).Row = 1 Then Exit For
        Fra_ark.Range(Fra_ark.Cells(1, I), Fra_ark.Cells(65536, I + 1).End(xlUp)).Copy _
                Til_ark.Cells(65536, 2).End(xlUp).Offset(1, 0)
    Next
    Til_ark.Activate
    Range("B3").Select
    Application.CutCopyMode = False
    Range("A1:C" & Cells(65536, 2).End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlDescending, Header:= _
                                                      xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                                      DataOption1:=xlSortNormal
                                                     
    For Each C In Range("C2:C" & Cells(65536, 3).End(xlUp).Row)
    C.Offset(0, -2) = Application.WorksheetFunction.Rank(C, Range("C2:C" & Cells(65536, 3).End(xlUp).Row))
Next
End Sub
Avatar billede excelent Ekspert
03. juni 2008 - 23:36 #3
Sub Flyt()
Set sh1 = Sheets("Ark1")
Set sh2 = Sheets("Ark2")
Set sh3 = Sheets("Ark3")
kol = sh1.Cells(1, 255).End(xlToLeft).Column

For t = 1 To kol Step 2
rk = rk + 1
sh2.Cells(rk, 1) = sh1.Cells(1, t)
sh2.Cells(rk, 2) = sh1.Cells(1, t + 1)
Next

sh2.Range("A1:B" & rk).Sort Key1:=sh2.Range("B1"), Order1:=xlDescending
sh2.Range("A1:B" & rk + 1).Copy sh3.Range("B2")
sh3.Range("A1") = "Pladsering"
sh3.Range("B1") = "Navn"
sh3.Range("C1") = "Point"
sh3.Range("A2").Formula = "=rank(C2,$C$2:$C$" & rk + 1 & ")"
sh3.Range("A2").AutoFill Destination:=sh3.Range("A2:A" & rk + 1)
End Sub
Avatar billede barentsen Novice
04. juni 2008 - 09:45 #4
Kabbak: Din kode opretter fint kolonneoverskrifterne i ark2, men der kommer ingen data med over.
Runtime error '13': Type mismatch
Hvis jeg vælger debug markeres sidste linie:  C.Offset(0, -2) = Application.WorksheetFunction.Rank(C, Range("C2:C" & Cells(65536, 3).End(xlUp).Row))

Har du et bud på hvad der er galt?

Excellent's svar virker, så jeg kan komme videre... - men den fulde løsning ville jo ikke være dum.
Avatar billede excelent Ekspert
04. juni 2008 - 10:58 #5
Hvad har jeg glemt ?
Avatar billede barentsen Novice
04. juni 2008 - 11:44 #6
excelent: Du har ikke glemt noget. Dvs. du har løst selve opgaven med at flytte listen til et nyt ark, og sætte dataene under hinanden. TAK for det, og det skal du selvfølgelig have point for, da du var først med en løsning der virker.
Men "Ekstraopgaven" og "Superopgaven" som beskrevet i teksten har du ikke løst.
Det er det som Kabbak også har gang i, men som jeg ikke kan få til at virke - så jeg håber at han (eller du) kan og har lyst til at lave dette også...
Avatar billede barentsen Novice
04. juni 2008 - 12:37 #7
Sorry excelent - jeg havde ikke set, at du havde lavet løsningen, så den kom i ark3.
Alt ser ud til at være som det skal. MANGE tak - nu er pointene endnu mere fortjente.
Læg et svar.
Avatar billede kabbak Professor
04. juni 2008 - 12:40 #8
her du rettet
Set Fra_ark = Worksheets("Ark1")

til dit dataark
Avatar billede excelent Ekspert
05. juni 2008 - 06:40 #9
ok velbekom
Avatar billede excelent Ekspert
14. juni 2008 - 12:08 #10
husk lige at lukke
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
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

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