Chỉ là gợi ý bạn thực hiện thử xem sao : Bạn dùng sự kiện Worksheet_Change. Trong đó, mỗi khi nhập liệu thì nó sẽ kiểm tra nội dung. Nếu thấy nội dung có chứa từ "địa chỉ" thì nó thêm ký tự xuống dòng trước từ "địa chỉ" ( &Chr(13) ). Cuối cùng, gán nội dung mới trở lại cho Cell
Xin phép góp 1 code
Sub XuongDong()
Dim eRow As Long, iText As String, jText As String
jText = [f1] 'diachi cai nayphai gan cho 1 cell nao do thi no moi hieu unicode
eRow = [A65000].End(xlUp).Row 'dong cuoi
For i = 1 To eRow
iText = WorksheetFunction.Clean(Range("A" & i)) 'Remove Chr(13)
iText = Replace(iText, jText, Chr(10) & jText, 1) 'them Chr(13)
Range("A" & i) = iText 'gan lai
Next
With Range("A1:A" & eRow) 'dinh dang co wraptext
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Resume Next
If Not Intersect([A1:A100], Target) Is Nothing Then
Target = Replace(Target, " " & Evaluate("DC"), Chr(10) & Evaluate("DC"), 1)
End If
Application.EnableEvents = True
End Sub
[B]
Function BreakDown(strSource As String, strSeparator As String) As String
BreakDown = Replace(strSource, strSeparator, vbNewLine & strSeparator)
End Function
[/B]Function BreakByLen(strSource As String, iLength As Long) As String
If iLength <= 0 Then
BreakByLen = strSource
Exit Function
End If
Dim strRet As String
strRet = ""
Do While Len(strSource) > iLength
strRet = strRet & Mid(strSource, 1, iLength) & vbNewLine
strSource = Mid(strSource, iLength + 1)
Loop
BreakByLen = strRet & strSource
End Function
Mình đoán vầy:
Ôi dào... tưởng cái gì... Nếu là như thế thì cần gì viết hàm cho mệt! Hàm Excel đã có sẳn rồi đồng chí ơi (Nếu phải viết hàm thì tôi đâu cần dùng sự kiện WorkSheet_Change)
Cũng như đồng chí, sao khi gõ xong công thức thì tại cell này cũng cần Format Wrap text
Có thể tôi viết không được rõ nghĩa nên bạn rollover79 có viết hàm "BreakByLen" như bài đã đăng. Vậy tôi xin nói thêm cho rõ ràng hơn: Khi tôi ở một cell bất kỳ ( một ô nào đó ), cứ đánh các ký tự " tràn cung mây" như trong word và theo mặc định nếu quá 255 ký tự nó sẽ tự động nhảy tiếp các ký tự xuống ô dưới và cứ như thế cho đến khi mình đánh xong đoạn văn thì thôi.
Tôi hiểu ý bạn! Vậy nhiệm vụ của ta là tìm ký tự rổng nằm gần với vị trí 255 rồi thay nó thành Chr(10)...
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Resume Next
If Not Intersect([A1:A100], Target) Is Nothing Then
''''''Target = Replace(Target, " " & Evaluate("DC"), Chr(10) & Evaluate("DC"), 1)
Target = BreakByLen(Target, 10)
End If
Application.EnableEvents = True
End Sub
Function BreakByLen(ByVal strSource As String, ByVal iLength As Long) As String
If iLength <= 0 Then
BreakByLen = strSource
Exit Function
End If
Dim strRet As String
strRet = ""
Do While Len(strSource) > iLength
strRet = strRet & Mid(strSource, 1, iLength) & vbNewLine
strSource = Mid(strSource, iLength + 1)
Loop
BreakByLen = strRet & strSource
End Functionbạn xem file thử. Vùng breakdown là F1:F3
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Resume Next
Dim arrTemp, i
Dim iColumn, iRow
iColumn = Target.Column
iRow = Target.Row
If Not Intersect([A1:A100], Target) Is Nothing Then
'Target = Replace(Target, " " & Evaluate("DC"), Chr(10) & Evaluate("DC"), 1)
'Target = BreakByLen(Target, 10)
arrTemp = Split(BreakByLen(Target, 10), Chr(10))
For i = LBound(arrTemp) To UBound(arrTemp)
Cells(iRow, iColumn) = arrTemp(i)
iRow = iRow + 1
Next
End If
Application.EnableEvents = True
End Sub
Function BreakByLen(ByVal strSource As String, ByVal iLength As Long) As String
If iLength <= 0 Then
BreakByLen = strSource
Exit Function
End If
Dim strRet As String
Dim iPos As Integer
Dim strTemp As String
strRet = ""
strTemp = ""
Do While Len(strSource) > iLength
strTemp = Mid(strSource, 1, iLength)
iPos = InStr(strTemp, Chr(10))
If iPos = 0 Then iPos = InStrRev(strTemp, " ")
If iPos > 0 Then strTemp = Mid(strTemp, 1, iPos - 1)
If Mid(strSource, Len(strTemp) + 1, 1) = Chr(10) Then
strSource = Mid(strSource, Len(strTemp) + 2)
Else
strSource = Mid(strSource, Len(strTemp) + 1)
End If
strRet = strRet & strTemp & Chr(10)
Loop
BreakByLen = strRet & strSource
End Function iRow = iRow + 1
If i <> UBound(arrTemp) And Cells(iRow, iColumn) <> "" Then Cells(iRow, iColumn).Insert
