Mã:
Sub TachTumLum()
' split one long string into segments
' this procedure assumes that the string is normal, ie you dont have to trim
Const SHEETNAME = "nhaplieu"
Const SEGLEN = 500
Const WBOUNDARY = " " ' if punctuation marks also count, you need a string list
Dim str As String
Dim segSt As Integer, segEn As Integer, finalPos As Integer ' segment start, end & final position
Dim segments() As Integer, segTot As Integer
' Firstly, establish an array of segment positions in the string
ReDim segments(1 To 2, 1 To 1)
str = Worksheets(SHEETNAME).Range("b3").Value ' read the original string
finalPos = Len(str)
segSt = 1
Do While segSt <= finalPos
segEn = segSt + SEGLEN ' the position is 1 character beyond required segment length
If segEn > finalPos Then
segEn = finalPos
Else
Do While Mid(str, segEn, 1) <> WBOUNDARY ' find the word boundary
segEn = segEn - 1
Loop
segEn = segEn - 1
End If
' write the positions to array
segTot = segTot + 1
ReDim Preserve segments(1 To 2, 1 To segTot)
segments(1, segTot) = segSt
segments(2, segTot) = segEn
' Debug.Print Mid(str, segSt, segEn - segSt + 1)
' Mid(str, segSt, segEn - segSt + 1) is the string segment we want
' add code to write them to worksheet here
segSt = segEn + 2
Loop
' Secondly, write the segments down onto worksheet
Const BLOCKCOLS = 6
Const WRITESTART = "D5"
Dim rg As Range, i As Integer, col As Integer, row As Integer
Set rg = Worksheets(SHEETNAME).Range(WRITESTART)
row = 1: col = 0
For i = 1 To segTot
col = col + 1
If col > BLOCKCOLS Then row = row + 1: col = 1
rg.Cells(row, col).Value = Mid(str, segments(1, i), segments(2, i) - segments(1, i) + 1)
Next i
End Sub
