07. maj 2008 - 23:09
Der 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.
031207 ddmmåå/Initialer
95266 Siem Closed 131207 Padbor 131207 14:47/msj Så kom..
131207 ddmmåå/Initialer
131207 ddmmåå/Initialer
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.
På forhånd tak - fra Hjertet
Rem Option Explicit
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
