22. april 2008 - 10:28Der er
13 kommentarer og 2 løsninger
Generer unik liste (300.000 linier)
Hej XLer
Jeg har virke brug for noget ekspert viden her
Jeg har en projektmappe med over 300.000 linjer fordelt på 12 ark
I kolonne A står det en tekst og i kolonne B står et nummer Mange af teksterne i kolonne A er ens og jeg kunne godt tænke mig at generer en ny liste hvor dobbeltgængerne er fjernet og tallene er lagt sammen for de tekster der er ens.
I dette særtema ser vi på, hvordan cloud og AI bliver fundamentet for virksomhedernes digitale forretning, og hvordan de nye muligheder for automatisering og forretningsværdi kan udnyttes uden at miste overblik, sikkerhed og menneskelig kontrol.
Tak - så vil jeg tro at løsningen kunne blive følgende: Gennemgang af hvert ark - række for række. For enhverv celle i kolonne A udføres en søgning i et "SumArk" (Nyt). Hvis A-tekst ikke findes - oprettes det og tal placeres i kolonne B Hvis A-tekst findes - adderes tal til kolonne B. Der skal føres løbende kontrol af, at rækkenr i SumArk ikke overstiger maks - er det tilfældet skiftes kolonner - f.eks. til D & E
Rem Koden anbringes i ThisWorkbook Rem Igangsættes fra VBA (nedenstående Sub F5) eller fra regnearket Alt+F8 - Startopdatering
Const maxRække = 65000 Public Sub startOpdatering() Dim ark, sidsteRæk, ræk Dim tekst, tal Dim nxtSumræk, tekstkol nxtSumræk = 1 tekstkol = 1
Rem Slet evt. optælling på SumArk clearSumArk
Rem Gennemgang af alle ark (excl. SumArk) For Each ark In ActiveWorkbook.Sheets
If LCase(ark.Name) <> "sumark" Then ActiveWorkbook.Sheets(ark.Name).Activate sidsteRæk = ActiveCell.SpecialCells(xlLastCell).Row For ræk = 1 To sidsteRæk tekst = ActiveSheet.Cells(ræk, 1) tal = ActiveSheet.Cells(ræk, 2)
Rem opdater kun hvis tekst er udfyldt If tekst <> "" Then opdaterTekst tekst, tal, nxtSumræk, tekstkol End If Next ræk End If Next
ActiveWorkbook.Sheets("SumArk").Activate
MsgBox ("Opdatering er afsluttet") End Sub Private Sub opdaterTekst(tekst, tal, nxtSumræk, tekstkol) Dim sumArk Set sumArk = ActiveWorkbook.Sheets("SumArk")
With sumArk.Range("A1:N65000") Set c = .Find(tekst, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then Rem Tekst er fundet række = c.Row kol = c.Column sumArk.Cells(række, kol + 1) = .Cells(række, kol + 1) + tal Else sumArk.Cells(nxtSumræk, tekstkol) = tekst sumArk.Cells(nxtSumræk, tekstkol + 1) = tal
nxtSumræk = nxtSumræk + 1
Rem Check at næsteSum-række ikke overstiger 65000 - i.g.f. forskyd kolonne m/3 If nxtSumræk > maxRække Then nxtSumræk = 1 tekstkol = tekstkol + 3 End If End If End With End Sub Private Sub clearSumArk() ActiveWorkbook.Sheets("SumArk").Activate Cells.ClearContents End Sub
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.