03. juni 2008 - 22:17Der 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.
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
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
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.
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å...
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.
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.