Del linje efter sidste hele ord før x karakterer

Denne artikel kunne med nogen ret hedder "Variationer over et tema". Temaet er i alle tilfælde, at få delt en celles indhold i to celler, hvis dette overstiger x antal tegn, fx 40, 60 eller 80. Der skal ikke deles præcis ved angivne antal tegn, men ved det nærmeste mellemrum mellem to ord, før det specificerede antal tegn.

Sætningen jeg vil "lege med" kunne være:

"Onkel Jans festlige festsange til enhver lejlighed kommer aldrig til ulejlighed."

Den første variation over temaet deler den aktive celle, så det, der flyttes, flyttes til cellen til højre for den aktive, mens den øvrige del bliver stående i den oprindelige celle.

Sub DelTekstFoer()
    Dim Mlr As Byte, Txt As String
    Txt = ActiveCell.Value
    Mlr = InStrRev(Txt, " ", 60)
    ActiveCell.Value = Left(Txt, Mlr - 1)
    ActiveCell.Offset(0, 1).Value = Mid(Txt, Mlr + 1, Len(Txt))
End Sub

Her er længden 60 indkodet direkte i makroen., men den kunne også være variabel, fx komme fra en inputbox:

Sub DelTekstFoer()
    Dim Mlr As Byte, Txt As String
    Txt = ActiveCell.Value
    Mlr = InStrRev(Txt, " ", InputBox("Indtast det største antal bogstaver, der må stå i cellen!"))
    ActiveCell.Value = Left(Txt, Mlr - 1)
    ActiveCell.Offset(0, 1).Value = Mid(Txt, Mlr + 1, Len(Txt))
End Sub

eller fra en celle i regnearket:

Sub DelTekstFoer()
    Dim Mlr As Byte, Txt As String
    Txt = ActiveCell.Value
    Mlr = InStrRev(Txt, " ", Range("D1"))
    ActiveCell.Value = Left(Txt, Mlr - 1)
    ActiveCell.Offset(0, 1).Value = Mid(Txt, Mlr + 1, Len(Txt))
End Sub

Men måske skal koden ikke kun virke på den aktive celle. Skal den fx altid virke på en bestemt celle i arket, kan man ændre Activecell til fx Range("a1").Value.

De næste eksempler arbejder alle sammen på flere rækker, i første omgang på de markerede rækker:

Sub DelTekst()
    On Error GoTo fejl:
    Dim Mlr As Byte, Txt As String, Lgd As Integer
    Lgd = InputBox("Indtast det største antal bogstaver, der må stå i cellen!")
    For Each c In Selection.Cells
        Txt = c.Value
        Mlr = InStrRev(Txt, " ", Lgd)
        c.Offset(0, 1).Value = Left(Txt, Mlr - 1)
        c.Offset(0, 2).Value = Mid(Txt, Mlr + 1, Len(Txt))
        'c.Clear
    Next c
    Exit Sub
fejl:
    If Err.Number = 5 Then
        MsgBox "Teksten er ikke " & Lgd & " lang, så den kan ikke deles", vbOKOnly + vbExclamation
    End If
    End Sub
 

Den første del af teksten flyttes til cellen lige til højre for den oprindelige og den sidste del til cellen to til højre for. Den oprindelige celle ændres der ikke noget ved. Er teksten i bare én af cellerne kortere end den værdi, der skal deles ved, vises en fejlmeddelelse og kun linjerne før den første, for korte linje bliver delt. Ønsker man at den oprindelige tekst skal slettes efter opdelingen, skal man bare fjerne udkommenteringen foran c.Clear.

Skal tekster, der er kortere end den angivne værdi bare flyttes til den første af de to kolonner, kan følgende anvendes:

Sub DelFlereTekst()
Dim Mlr As Byte, Txt As String, Lgd As Integer
    Lgd = InputBox("Indtast det største antal bogstaver, der må stå i cellen!")
    For Each c In Selection.Cells
        Txt = c.Value
        Mlr = InStrRev(Txt, " ", Lgd)
        If Len(Txt) <= 60 Then
            c.Offset(0, 1).Value = c.Value
        Else
            c.Offset(0, 1).Value = Left(Txt, Mlr - 1)
            c.Offset(0, 2).Value = Mid(Txt, Mlr + 1, Len(Txt))
        End If
        'c.Clear
    Next c
Exit Sub

Igen kan den oprindelige tekst slettes ved at fjerne udkommenteringen foran c.Clear.

- Tilbage til makroer -
- Tilbage til Excel -