07. maj 2008 - 23:09Der er
5 kommentarer og 1 løsning
Flytning og samling af tekster (VBA)
Er der en af Jer kære, dygtige Excel-hajer, der kan hjælpe med følgende?
Eksempel:
A B C D E F G Sag Arb.grp Status Start Emne Beskrivelse Beskriv 2 94414 Sie Closed 031207 Dysseg 031207/Cha: Bl. ddmmåå/In 95220 BDK Parked 131207 Dysseg 13-12-07 05:12 ddmmåå/In 94406 Sie Accept 031207 Esperg 080107 AAN: ud.
Indholdet i de fleste af kolonnerne er forkortet for at kunne være på denne side
Kolonne A indeholder: - enten et 5 eller 6-cifret sagsnummer - Så vidt jeg kan se alle formatteret som tal (højrestillet) - eller tekst (venstrestillet)
Kolonne B indeholder: - enten navnet på den arbejdsgruppe, der skal have sagen - eller (hvis kolonne A indeholder tekst)teksten "ddmmåå/Initialer"
Sagsnummer i kolonne A hører til i kolonne A Tekst i kolonne A hører til i kolonne F Arbejdsgruppenavn i kolonne B hører til i kolonne B Teksten "ddmmåå/Initialer" i kolonne B hører til i kolonne G
Der optræder tilfældigt tomme rækker - som i ovenstående eksempel linie 5,8 og 10. Disse kan selvfølgelig slettes
Tekst i kolonne F ønskes samlet i én celle - for hvert enkelt sagsnummer. Med linieskift for hver tekstlinie Altså - eksempelvis: Teksten i A6 skal sammenføjes med F4. Og A9 og A11 skal sammenføjes med F7
De tilsvarende B6, B9 og B11 må gerne flyttes ud i kolonne G Men teksten "ddmmåå/Initialer" i kolonne B og kolonne G er egentlig ligegyldig. Kan slettes - eller?
Er der en, der kan lave makroen, der kan flytte og samle teksterne (og slette overflødige linier)? Skal kunne køre automatisk, da der er 30-40.000 rækker i arket.
Rem Version 2 Rem ========= Dim antalRæk, SDRække Sub dataKomprimering_2() Application.ScreenUpdating = False antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
traverserRækker
Application.ScreenUpdating = True MsgBox ("DataKomprimering afsluttet") End Sub Private Sub traverserRækker() Dim kolA, kolB, formel SDRække = 0
For ræk = 2 To antalRæk If ræk > antalRæk Then Exit Sub End If
kolA = Cells(ræk, 1) kolB = Cells(ræk, 2)
Rem Test om fejl i kol A p.g.a. "-", så fjern "=" indsæt apostrof foran If IsError(kolA) = True Then formel = Cells(ræk, 1).Formula If InStr(Cells(ræk, 1).Formula, "=-") > 0 Then kolA = Chr(39) + Mid(formel, 2) End If If InStr(Cells(ræk, 1).Formula, "=+") > 0 Then 'LJE: Der testes også for =+ kolA = Chr(39) + Mid(formel, 2) End If
End If
Rem Test om kolonne A er tom - så slet række If kolA = "" Then sletRække ræk ræk = ræk - 1 'modificer - så næste række er aktualiseret Else
Rem Test om numerisk i kolone A & er udfyldt - hvis Ja gem rækkeNr 'LJE: Kolonne A kan indeholde andet end sagsnumre. Test for om tallet er under 70000 ' fra 01.01.2007 er sagsnumre over 70000 (det fjerner en hel del lokalnumre) ' - samt under 200000 (der fjerner en hel del tlf.numre) If IsNumeric(kolA) = True And kolA <> "" And kolA > 70000 And kolA < 200000 Then SDRække = ræk Else Rem Ej numerisk og udfyldt - opdater Kol L i sidste SDRække opdaterKol_L kolA
If LCase(kolB) = "ddmmåå/initialer" Then opdaterKol_M kolB End If
formaterSDrække
sletRække ræk ræk = ræk - 1 End If End If Next ræk End Sub Private Sub sletRække(rækNr) Rows(rækNr).Select Selection.Delete Shift:=xlUp antalRæk = antalRæk - 1
End Sub Private Sub opdaterKol_L(kolA) Dim ptKolL Rem Fjern apostrof igen, hvis denne findes i pos. 1 If Left(kolA, 1) = Chr(39) Then kolA = Mid(kolA, 2) End If
ptKolL = Cells(SDRække, 12) If ptKolL = "" Then Cells(SDRække, 12) = kolA Else Cells(SDRække, 12) = Cells(SDRække, 12) & Chr(10) & kolA 'LJE: + ændret til & End If End Sub Private Sub opdaterKol_M(kolB) Dim ptKolM ptKolM = Cells(SDRække, 13) If ptKolM = "" Then Cells(SDRække, 13) = kolB Else Cells(SDRække, 13) = Cells(SDRække, 13) & Chr(10) & kolB 'LJE: + ændret til & End If End Sub Private Sub formaterSDrække() Rows(SDRække).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .EntireRow.AutoFit End With 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.
