Tách chuỗi có chữ số và những ký tự đặc biệt

[ndu96081631]

Xin cho hỏi: On Error GoTo NextStp cái này khác gì bẫy lỗi On Error Resume Next?

Khác nhau ở chổ:
- Resime Next: Gặp lỗi thì đi tiếp
- Goto "Nhản nào đó": Gặp lỗi "bay thẳng" đến vị trí tên nhản đã chỉ định (chữ NextStp là do bạn tự đặt, không phải từ khóa)

 

[trungvdb]

Thưa thày Ndu, bài này ta có cách nào (có thể dùng kết hợp cả Sub) mà không cần dùng đến biến Post cũng làm được không ah?

Function SepString(Text As String, Pos As Long)
  On Error GoTo NextStp
  Text = Mid(Text, InStr(Text, "(") + 1, Len(Text))
  Text = Replace(Text, ")", "")
  Text = Replace(Text, " ", "")
  Text = Replace(Text, ";", " ")
  Text = Replace(Text, "/", " ")
  SepString = Split(Text, " ")(Pos - 1)
  If SepString = "" Then SepString = 0
  Exit Function
NextStp:
  SepString = ""
End Function

 

[ndu96081631]

Thưa thày Ndu, bài này ta có cách nào (có thể dùng kết hợp cả Sub) mà không cần dùng đến biến Post cũng làm được không ah?

Đương nhiên là được
1> Sửa lại hàm:

Function SepString(ByVal Text As String)
  Dim Arr, tmp As String
  On Error Resume Next
  tmp = Text
  tmp = Mid(tmp, InStr(tmp, "(") + 1, Len(tmp))
  tmp = Replace(tmp, ")", "")
  tmp = Replace(tmp, " ", "")
  tmp = Replace(tmp, ";", " ")
  tmp = Replace(tmp, "/", " ")
  Arr = Split(tmp, " ")
  SepString = Arr
End Function

2> Dùng Sub để tách:

Sub Main()
  Dim sArray, Arr(), tmp, Text As String, lR As Long, lC As Long, n As Long, maxC As Long
  On Error GoTo ExitSub
  With Sheet1.Range("A6:A1000")
    sArray = .Value
    n = 1: maxC = 2
    ReDim Arr(1 To UBound(sArray, 1), 1 To maxC)
    For lR = 1 To UBound(sArray, 1)
      If Len(Trim(CStr(sArray(lR, 1)))) Then
        Text = Trim(CStr(sArray(lR, 1)))
        Arr(lR, 1) = Text
        tmp = SepString(Text)
        If IsArray(tmp) Then
          If maxC < UBound(tmp) + 1 Then
            maxC = UBound(tmp) + 1
            ReDim Preserve Arr(1 To UBound(sArray, 1), 1 To maxC + 1)
          End If
          For lC = 1 To UBound(tmp) + 1
            Arr(lR, lC + 1) = IIf(tmp(lC - 1) = "", 0, tmp(lC - 1))
          Next
        End If
      End If
    Next
    .Resize(, maxC + 1).Value = Arr
  End With
ExitSub:
End Sub

Nếu dữ liệu bố trí khác, hãy thay Range("A6:A1000") thành vùng khác cho phù hợp