Code tách chuỗi theo điều kiện (1 người xem)

minhtuan55 · 25/4/17

Chào cả nhà GPE. Vấn đề này nó vô cùng khó.em đã mò gần 1 ngày mà chưa làm . Em gửi File cả nhà giúp em

concogia · 26/4/17

Bạn nói: Kiểu dạng text: dd, d, da, dx và dấu chấm sao cell [B4] có thằng màu đỏ
123d50d90.123dd80.123.145.154dd90.123.155.168d80d90.55b60
Thằng này tính sao đây?

minhtuan55 · 26/4/17

concogia đã viết:
Bạn nói: Kiểu dạng text: dd, d, da, dx và dấu chấm sao cell [B4] có thằng màu đỏ
123d50d90.123dd80.123.145.154dd90.123.155.168d80d90.55b60
Thằng này tính sao đây?

Em nhầm Kiểu dạng text: dd, d, da, dx, b và dấu chấm nữa anh

befaint · 26/4/17

minhtuan55 đã viết:
Em nhầm Kiểu dạng text: dd, d, da, dx, b và dấu chấm nữa anh

Mã:

Public Function TDL(ByVal chuoi As String) As Variant
Const deli As String = "."
Const chk1 As String = "d"
Const chk2 As String = "b"
Dim sArr, i As Long, tmp As String, j As Long, k As Long, iT As Long, ct As Long
sArr = Split(chuoi, deli)
ReDim dArr(1 To UBound(sArr) + 1)
For i = LBound(sArr) To UBound(sArr)
    If i < ct Then GoTo 1
    tmp = sArr(i)
    If InStr(tmp, chk1) Or InStr(tmp, chk2) Then
        j = j + 1
        dArr(j) = tmp
    Else
        iT = 0: ReDim T(1 To UBound(sArr) + 1)
        For k = i To UBound(sArr)
            tmp = sArr(k)
            If InStr(tmp, chk1) Or InStr(tmp, chk2) Then
                iT = iT + 1
                T(iT) = sArr(k)
                ct = k + 1
                Exit For
            End If
            iT = iT + 1
            T(iT) = sArr(k)
            ct = k + 1
        Next k
        ReDim Preserve T(1 To iT)
        j = j + 1
        dArr(j) = Join(T, deli)
    End If
1:
Next i
If j Then
    ReDim Preserve dArr(1 To j)
    TDL = dArr
End If
End Function
'-------------------------------
Sub Main()
Dim sArr(), r As Long, i As Long, k As Long, Txt As String, tmp
Dim KQ(1 To 60000, 1 To 20)
sArr = Sheet1.Range("B3:B5").Value
For r = 1 To UBound(sArr, 1)
    Txt = sArr(r, 1)
    If Txt <> "" Then
        i = i + 1
        tmp = TDL(Txt)
        For k = LBound(tmp) To UBound(tmp)
            KQ(i, k) = tmp(k)
        Next k
    End If
Next r
If i Then
    Sheet1.Range("D3").Resize(i, 20) = KQ
End If
End Sub

minhtuan55 · 26/4/17

befaint đã viết:

Mã:

Public Function TDL(ByVal chuoi As String) As Variant
Const deli As String = "."
Const chk1 As String = "d"
Const chk2 As String = "b"
Dim sArr, i As Long, tmp As String, j As Long, k As Long, iT As Long, ct As Long
sArr = Split(chuoi, deli)
ReDim dArr(1 To UBound(sArr) + 1)
For i = LBound(sArr) To UBound(sArr)
    If i < ct Then GoTo 1
    tmp = sArr(i)
    If InStr(tmp, chk1) Or InStr(tmp, chk2) Then
        j = j + 1
        dArr(j) = tmp
    Else
        iT = 0: ReDim T(1 To UBound(sArr) + 1)
        For k = i To UBound(sArr)
            tmp = sArr(k)
            If InStr(tmp, chk1) Or InStr(tmp, chk2) Then
                iT = iT + 1
                T(iT) = sArr(k)
                ct = k + 1
                Exit For
            End If
            iT = iT + 1
            T(iT) = sArr(k)
            ct = k + 1
        Next k
        ReDim Preserve T(1 To iT)
        j = j + 1
        dArr(j) = Join(T, deli)
    End If
1:
Next i
If j Then
    ReDim Preserve dArr(1 To j)
    TDL = dArr
End If
End Function
'-------------------------------
Sub Main()
Dim sArr(), r As Long, i As Long, k As Long, Txt As String, tmp
Dim KQ(1 To 60000, 1 To 20)
sArr = Sheet1.Range("B3:B5").Value
For r = 1 To UBound(sArr, 1)
    Txt = sArr(r, 1)
    If Txt <> "" Then
        i = i + 1
        tmp = TDL(Txt)
        For k = LBound(tmp) To UBound(tmp)
            KQ(i, k) = tmp(k)
        Next k
    End If
Next r
If i Then
    Sheet1.Range("D3").Resize(i, 20) = KQ
End If
End Sub

Thank anh. Em đã test. Vô cùng chính xác anh nhé

Ba Tê · 26/4/17

minhtuan55 đã viết:
Em nhầm Kiểu dạng text: dd, d, da, dx, b và dấu chấm nữa anh

"Túm lại" chỉ có 3 loại Text, ".", "d", "b" (có "d" là được rồi, "d" gì cũng "đặng" phải không?

Mã:

Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, CoL As Long, Tmp
sArr = Range("B2", Range("B65536").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To UBound(sArr), 1 To 20)
For I = 2 To R
    CoL = 1: K = K + 1
    If sArr(I, 1) <> Empty Then
        Tmp = Split(sArr(I, 1), ".")
        For J = 0 To UBound(Tmp)
            dArr(K, CoL) = dArr(K, CoL) & IIf(dArr(K, CoL) = Empty, Tmp(J), "." & Tmp(J))
            If InStr(Tmp(J), "d") + InStr(Tmp(J), "b") Then CoL = CoL + 1
        Next J
    End If
Next I
Range("D3").Resize(K, 20) = dArr
End Sub

TheThienChu · 26/4/17

minhtuan55 đã viết:
Em nhầm Kiểu dạng text: dd, d, da, dx, b và dấu chấm nữa anh

Gủi bạn tham khảo đoạn code

Mã:

Option Explicit
Sub MySplit()
Dim SArr, Tmp, Res
Dim i, j, k, n, t

SArr = Sheet1.Range("B3", Sheet1.Range("B3").End(xlDown))
ReDim Res(1 To UBound(SArr), 1 To 1)
For i = 1 To UBound(SArr)
Tmp = Split(SArr(i, 1), ".")
t = "": n = 0
    For j = 0 To UBound(Tmp)
        For k = 1 To Len(Tmp(j))
            If IsNumeric(Mid(Tmp(j), k, 1)) = False Then n = n + 1: Exit For
        Next k
        If n = 0 Then
            t = t & " " & Tmp(j)
            Tmp(j) = ""
        Else
            If t <> "" Then
                Tmp(j) = t & " " & Tmp(j)
                Tmp(j) = Replace(Trim(Tmp(j)), " ", ".")
            End If
            t = "": n = 0
        End If
    Next j
    Tmp = Split(WorksheetFunction.Trim(Join(Tmp)))
    If UBound(Res, 2) < UBound(Tmp) + 1 Then
        ReDim Preserve Res(1 To UBound(SArr), 1 To UBound(Tmp) + 1)
    End If
    For j = 0 To UBound(Tmp)
        Res(i, j + 1) = Tmp(j)
    Next j
Next i
Sheet1.Range("D3").Resize(UBound(Res), 20).ClearContents
Sheet1.Range("D3").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub

minhtuan55 · 26/4/17

Ba Tê đã viết:

"Túm lại" chỉ có 3 loại Text, ".", "d", "b" (có "d" là được rồi, "d" gì cũng "đặng" phải không?

Mã:

Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, CoL As Long, Tmp
sArr = Range("B2", Range("B65536").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To UBound(sArr), 1 To 20)
For I = 2 To R
    CoL = 1: K = K + 1
    If sArr(I, 1) <> Empty Then
        Tmp = Split(sArr(I, 1), ".")
        For J = 0 To UBound(Tmp)
            dArr(K, CoL) = dArr(K, CoL) & IIf(dArr(K, CoL) = Empty, Tmp(J), "." & Tmp(J))
            If InStr(Tmp(J), "d") + InStr(Tmp(J), "b") Then CoL = CoL + 1
        Next J
    End If
Next I
Range("D3").Resize(K, 20) = dArr
End Sub

Dạ đúng rồi anh. Code anh đúng rồi. Em tự thêm 1 đoạn nữa để Đề phòng chử HOA
Tmp = Split(LCase(sArr(I, 1)), ".")
không biết có ảnh hưởng gì không anh

minhtuan55 · 26/4/17

TheThienChu đã viết:

Gủi bạn tham khảo đoạn code

Mã:

Option Explicit
Sub MySplit()
Dim SArr, Tmp, Res
Dim i, j, k, n, t

SArr = Sheet1.Range("B3", Sheet1.Range("B3").End(xlDown))
ReDim Res(1 To UBound(SArr), 1 To 1)
For i = 1 To UBound(SArr)
Tmp = Split(SArr(i, 1), ".")
t = "": n = 0
    For j = 0 To UBound(Tmp)
        For k = 1 To Len(Tmp(j))
            If IsNumeric(Mid(Tmp(j), k, 1)) = False Then n = n + 1: Exit For
        Next k
        If n = 0 Then
            t = t & " " & Tmp(j)
            Tmp(j) = ""
        Else
            If t <> "" Then
                Tmp(j) = t & " " & Tmp(j)
                Tmp(j) = Replace(Trim(Tmp(j)), " ", ".")
            End If
            t = "": n = 0
        End If
    Next j
    Tmp = Split(WorksheetFunction.Trim(Join(Tmp)))
    If UBound(Res, 2) < UBound(Tmp) + 1 Then
        ReDim Preserve Res(1 To UBound(SArr), 1 To UBound(Tmp) + 1)
    End If
    For j = 0 To UBound(Tmp)
        Res(i, j + 1) = Tmp(j)
    Next j
Next i
Sheet1.Range("D3").Resize(UBound(Res), 20).ClearContents
Sheet1.Range("D3").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub

dạ tuyệt vời cảm ơn anh nhiều lắm

Code tách chuỗi theo điều kiện (1 người xem)

Người dùng đang xem chủ đề này

minhtuan55

Thành viên bị đình chỉ hoạt động

File đính kèm

concogia

Gội rồi mới Cạo

minhtuan55

Thành viên bị đình chỉ hoạt động

befaint

|||||||||||||

minhtuan55

Thành viên bị đình chỉ hoạt động

Ba Tê

Cạo Rồi Khỏi Gội

TheThienChu

Thành viên tiêu biểu

minhtuan55

Thành viên bị đình chỉ hoạt động

minhtuan55

Thành viên bị đình chỉ hoạt động

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian