13. november 2013 - 13:56
Der er
5 kommentarer
Copy range if spørgsmål
TK02 166.047.324,19
TK02 108.828.879,94
TK02 64.125.528,08
TK02 41.449.829,61
TK02 27.702.228,51
TK02 16.227.067,14
TK02 14.401.111,58
TK02 12.398.163,04
TK02 10.656.098,89
TK02 7.841.674,31
TK02 6.667.772,08
TK02 6.068.510,38
TK02 5.397.283,16
TK02 5.300.443,98
TK02 3.527.836,38
TK02 1.240.557,80
TK02 1.154.350,73
TK02 1.144.466,31
TK02 1.059.759,03
TK02 891.158,47
TK02 644.079,46
TK02 580.568,56
TK02 344.288,60
TK02 58.710,53
TK01 184.906.267,57
TK01 45.593.191,50
TK01 38.359.851,68
TK01 25.444.928,22
TK01 24.500.378,15
TK01 22.129.918,05
TK01 14.658.297,88
TK01 14.487.587,44
TK01 10.888.062,14
TK01 5.908.063,31
TK01 5.770.729,40
TK01 5.057.958,89
TK01 4.321.694,99
TK01 3.731.970,24
TK01 3.501.820,26
TK01 3.266.219,15
TK01 3.070.782,70
TK01 2.947.863,52
TK01 2.873.903,92
TK01 2.847.113,59
TK01 2.649.331,44
TK01 2.565.684,38
TK01 2.377.154,86
TK01 2.302.766,95
TK01 1.981.310,04
TK01 1.876.536,92
TK01 1.696.382,42
TK01 1.680.539,61
TK01 1.579.404,79
TK01 1.049.274,65
TK01 618.510,95
TK01 560.175,87
TK01 525.415,30
TK01 497.072,34
TK01 467.574,11
TK01 445.939,51
TK01 373.374,19
TK01 371.783,22
TK01 314.156,79
TK01 274.207,72
TK01 210.868,31
TK01 202.059,99
TK01 188.344,46
TK01 115.154,41
Jeg har ovenstående data. Jeg vil gerne have en kode, sådan at den kopiere de 20 første/største værdier hvis værdi i A er = TK02.
og så indsætter i andre celle (dette kan jeg nok godt selv klare)
Tilsvarende vil jeg gerne lave en som tager de 20 første/største hvis værdier i A = TK01.
Tidligere har jeg forsøgt mig med filter, men det dur ikke da antallet er henholdsvis TK01 og TK02 varierer fra gang til gang makroen skal køres.
16. november 2013 - 16:30
#5
Hejsa,
Herunder et forslag.
Bemærk at mit forslag inkluderer at du skal have to yderligere faneblade. Det ene skal hedde "S" og det andet skal hedde "Resultat"
Option Explicit
Dim Titel As String
Dim Værdi As Long
Dim RK As Long
Dim Bund As Long
Dim Kol As Long
Dim Top As Long
Sub fIND_20()
'Sletter alle data i arket "Resultat"
Sheets("Resultat").Select
Cells.Select
Selection.Delete
Cells(1, 1).Select
'Sletter alle data i arket "S"
Sheets("S").Select
Cells.Select
Selection.Delete
Cells(1, 1).Select
Sheets("data").Select
'Sorterer Data efter titel
Cells(1, 1).Select
ActiveWorkbook.Worksheets("data").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("data").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("data").Sort
.SetRange Range("a1:B10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Navngiver variabel med titel
Titel = Cells(2, 1)
'Finder sidste celle med samme titel og navngiver variablen Bund med pågældende rækkenummer
RK = 2
Do
RK = RK + 1
Loop Until Cells(RK, 1) <> Titel
Bund = RK - 1
'bruger de to variabler til at kopiere det valgte område til arkket "S"
Range(Cells(1, 1), Cells(Bund, 2)).Select
Selection.Copy
Sheets("S").Select
ActiveSheet.Paste
Cells.Select
Selection.EntireColumn.AutoFit
Cells(1, 2).Select
'Sorterer efter kolonnen "Værdi" med højeste værdi øverste
Range("B1").Select
ActiveWorkbook.Worksheets("S").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("S").Sort.SortFields.Add Key:=Range("B1"), SortOn _
:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("S").Sort
.SetRange Range("A2:B10000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Vælger de 20 øverste rækker (udover overskrifterne) og kopierer disse over i feltet "Resultat"
Range(Cells(1, 1), Cells(21, 2)).Select
Selection.Copy
Sheets("Resultat").Select
ActiveSheet.Paste
Cells(2, 1).Select
'--------------------------------------------------------------------------------------------------------------
'Her begynder andet gennemløb
'Sletter alle data i fanen "S"
Sheets("S").Select
Cells.Select
Selection.Delete
Cells(1, 1).Select
Sheets("data").Select
'Sorterer data efter kolonnen Titel
Cells(1, 1).Select
ActiveWorkbook.Worksheets("data").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("data").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("data").Sort
.SetRange Range("a1:B10000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Navngiver variabel med titel
Titel = Cells(2, 1)
'Søger i kolonnen til indholdet af kolonne 1 ikke længere svarer til variabel-navnet
RK = 2
Do
RK = RK + 1
Loop Until Cells(RK, 1) <> Titel
Top = RK
'Navngiver variabel med titel
Titel = Cells(RK, 1)
'Søger i kolonnen til indholdet af kolonne 1 ikke længere svarer til variabel-navnet
Do
RK = RK + 1
Loop Until Cells(RK, 1) <> Titel
RK = RK - 1
Bund = RK
'kopiere det valgte område og indsætter det i fanen "S"
Range(Cells(Top, 1), Cells(Bund, 2)).Select
Selection.Copy
Sheets("S").Select
ActiveSheet.Paste
Cells.Select
Selection.EntireColumn.AutoFit
Cells(1, 2).Select
'Sorterer efter kolonnen "Værdi" med højeste værdi øverste
Range("B1").Select
ActiveWorkbook.Worksheets("S").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("S").Sort.SortFields.Add Key:=Range("B1"), SortOn _
:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("S").Sort
.SetRange Range("A2:B10000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Vælger de 20 øverste rækker (eksklusiv overskrifter) og kopierer disse over i feltet "Resultat"
Range(Cells(1, 1), Cells(20, 2)).Select
Selection.Copy
Sheets("Resultat").Select
Cells(2, 4).Select
ActiveSheet.Paste
'Tilføjer overskrifter til de to kolonner
Cells(1, 4) = "Titel"
Cells(1, 5) = "Værdi"
Cells.Select
Selection.EntireColumn.AutoFit
Cells(2, 4).Select
End Sub
Håber det kan bruges
Med venlig hilsen
Henrik
