Opsplitning af én kolonne til flere i Excel

VBA-koden indsættes som programkode under relevante Ark

Public Sub opdel()
Const maxTegn = 70
Dim antalRækker As Long
Dim ræk As Long, tekstA As String, tekstDel As String
Dim ix As Integer, kolNr As Byte

    Application.ScreenUpdating = False
   
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 1 To antalRækker
    kolNr = 2
   
        tekstA = Range("A" & CStr(ræk))
       
        While Len(tekstA) > maxTegn
            For ix = maxTegn To 1 Step -1
                If Mid(tekstA, ix, 1) = " " Then
                    tekstDel = Left(tekstA, ix)
                    Cells(ræk, kolNr) = tekstDel
                    tekstA = Mid(tekstA, ix + 1)
                    kolNr = kolNr + 1
                    Exit For
                End If
            Next ix
        Wend
    Next ræk
   
    ActiveSheet.Columns.AutoFit
    Application.ScreenUpdating = False
   
    MsgBox ("Opdeling udført")
End Sub

Hejsa,

Der er lige en lille ting. Hvis jeg kører VBA'en på linien :

Mål: 20 x 20 mm 10 forskellige lagerøjs motiver Kan vaskes på 50 grader.

kommer der kun :

Mål: 20 x 20 mm 10 forskellige lagerøjs motiver Kan vaskes på 50

i kolonne B og intet i kolonne C

Er det mig der ikke har afviklet koden korrekt ?

prøv

Sub DelOp()
kol = 1
rk = Cells(65500, 1).End(xlUp).Row
For t = 1 To rk
x = Cells(t, 1)
While x <> ""
kol = kol + 1
stk = InStrRev(Left(x, 70), " ", -1, vbTextCompare)
If stk = 0 Or Len(x) < 70 Then y = Left(x, 70) Else y = Left(x, stk)
x = Replace(x, y, "")
Cells(t, kol) = y
Wend
kol = 1
Next
End Sub

Nej - der manglede lige en "krølle"

Rem Version 2

Public Sub opdel()
Const maxTegn = 70
Dim antalRækker As Long
Dim ræk As Long, tekstA As String, tekstDel As String
Dim ix As Integer, kolNr As Byte

    Application.ScreenUpdating = False
   
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 1 To antalRækker
    kolNr = 2
   
        tekstA = Range("A" & CStr(ræk))
       
        While Len(tekstA) > maxTegn
            For ix = maxTegn To 1 Step -1
                If Mid(tekstA, ix, 1) = " " Then
                    tekstDel = Left(tekstA, ix)
                    Cells(ræk, kolNr) = tekstDel
                    tekstA = Mid(tekstA, ix + 1)
                    kolNr = kolNr + 1
                    Exit For
                End If
            Next ix
        Wend
       
        If Len(tekstA) > 0 Then
            Cells(ræk, kolNr) = tekstA
        End If
    Next ræk
   
    ActiveSheet.Columns.AutoFit
    Application.ScreenUpdating = False
   
    MsgBox ("Opdeling udført")
End Sub

Nu spiller det bare. Tusind tak :-)

Smider du et svar.

Ok - selv tak