Xóa các ký tự xuống dòng (Alt+Enter) bị thừa trong 1 cell

[sesongkhac]

Chúc ngày Quốc khánh 2/9 tràn ngập hạnh phúc vui vẻ
Mình muốn nhờ mọi người giúp xíu
mình có file excel nhưng trong đó có các ô mà có nội dung có các dòng xuống hàng trống ( có nhiều ô có nhiều hơn 1 cái xống dòng)

Mình muốn chỉ xuống dòng 1 lần và xóa các khoảng xuống dòng đó

Mình có đính kèm file cho mọi người dễ hiểu tại mình diễn đạt hơi lủng củng
Thank cả nhà ạ, chúc buổi tối vui vẻ ạ.

 

[giaiphap]

Chúc ngày Quốc khánh 2/9 tràn ngập hạnh phúc vui vẻ
Mình muốn nhờ mọi người giúp xíu
mình có file excel nhưng trong đó có các ô mà có nội dung có các dòng xuống hàng trống ( có nhiều ô có nhiều hơn 1 cái xống dòng)

Mình muốn chỉ xuống dòng 1 lần và xóa các khoảng xuống dòng đó

Mình có đính kèm file cho mọi người dễ hiểu tại mình diễn đạt hơi lủng củng
Thank cả nhà ạ, chúc buổi tối vui vẻ ạ.

Dùng thử đoạn code này xem sao?

Public Sub Del_AltEnter()
Dim Rng As Range, k, s$
For Each Rng In Sheet1.UsedRange
    s = ""
    For Each k In Split(Rng, ChrW$(10))
        If k <> "" Then s = IIf(s = "", k, s & ChrW$(10) & k)
    Next k
    If s <> "" Then Rng = s
Next Rng
End Sub

 

[VetMini]

Dùng thử đoạn code này xem sao?
...

Dùng Find-Replace được rồi, code cực lắm.
Find what: 2 ký hiệu xuống dòng
Replace with: 1 xuống dòng
Replace All đến khi nó báo lỗi đã hết Find được.

 

[ndu96081631]

Thí nghiệm thử với cái củ cải này:

Function SpecialTrim(ByVal Text As String, Optional ByVal CharToTrim = " ") As String
  With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "\" & CharToTrim & "{2,}"
    SpecialTrim = Trim(.Replace(Text, CharToTrim))
  End With
End Function
Sub Main()
  Dim cel As Range
  For Each cel In ActiveSheet.UsedRange
    If InStr(1, cel.Value, vbLf & vbLf) Then cel.Value = SpecialTrim(cel.Value, vbLf)
  Next
End Sub

Hên xui nha!

 

[sesongkhac]

Thank các bạn để mình thử ạ.

 

[ndu96081631]

Cho thêm một giải pháp "dân dã" nữa đây:

Sub Test()
  Dim cel As Range
  For Each cel In ActiveSheet.UsedRange
    If InStr(1, cel.Value, vbLf & vbLf) Then
      cel.Replace Space(1), vbBack, xlPart
      cel.Replace vbLf, Space(1), xlPart
      cel.Value = Application.Trim(cel.Value)
      cel.Replace Space(1), vbLf, xlPart
      cel.Replace vbBack, Space(1), xlPart
    End If
  Next
End Sub

Cách này chắc ai cũng hiểu

 

[sesongkhac]

file vi du thì chạy
còn file em muốn làm thì lại không chạy các bác à

 

[ndu96081631]

file vi du thì chạy
còn file em muốn làm thì lại không chạy các bác à

Ngay từ đầu đưa dữ liệu lên luôn đi là xong rồi. Cứ lấy ví dụ này nọ, có đúng với dữ liệu thật đâu chứ
Cái ký tự mà bạn nói là "xuống dòng" ấy thật ra nó là CHAR(13) + CHAR(10) <---- Tôi đoán dữ liệu này được copy từ đâu đó về (từ web hoặc từ 1 file txt)
Giải quyết
Thêm câu lệnh: ActiveSheet.UsedRange.Replace vbCrLf, vbLf, xlPart vào đầu code. Ví dũ:
1> Code 1:

Function SpecialTrim(ByVal Text As String, Optional ByVal CharToTrim = " ") As String
  With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "\" & CharToTrim & "{2,}"
    SpecialTrim = Trim(.Replace(Text, CharToTrim))
  End With
End Function
Sub Main()
  Dim cel As Range
  ActiveSheet.UsedRange.Replace vbCrLf, vbLf, xlPart
  For Each cel In ActiveSheet.UsedRange
    If InStr(1, cel.Value, vbLf & vbLf) Then cel.Value = SpecialTrim(cel.Value, vbLf)
  Next
End Sub

2> Code 2:

Sub Test()
  Dim cel As Range
  ActiveSheet.UsedRange.Replace vbCrLf, vbLf, xlPart
  For Each cel In ActiveSheet.UsedRange
    If InStr(1, cel.Value, vbLf & vbLf) Then
      cel.Replace Space(1), vbBack, xlPart
      cel.Replace vbLf, Space(1), xlPart
      cel.Value = Application.Trim(cel.Value)
      cel.Replace Space(1), vbLf, xlPart
      cel.Replace vbBack, Space(1), xlPart
      cel.Value = Application.Trim(cel.Value)
    End If
  Next
End Sub

Tùy ý bạn chọn chạy code 1 hay code 2 đều được