[Hỏi] Tách dữ liệu nguồn (1 cột) thành các dữ liệu đích (nhiều cột) với nhiều dấu hiệu nhận biết khác nhau

[duythanhmt]

Xin chào Anh, Chị, Em,

Hiện mình gặp vấn đề việc Tách dữ liệu nguồn (1 cột) thành các dữ liệu đích (nhiều cột) với nhiều dấu hiệu nhận biết khác nhau.
Hiện tại mình phải làm thủ công bằng cách chèn thêm cột rồi dùng các hàm trong Excel để tính.
Tuy nhiên do dữ liệu không đồng nhất nên trong cùng 1 cột lại phải dùng nhiều công thức khác nhau ở các dòng khác nhau.
Việc làm thủ công thao tác nhiều và lập đi lặp lại mỗi lần làm.

Xin nhờ Anh, Chị, Em xem giúp dùm mình có thể làm tự động (có thể bằng VBA):
- Tự động chèn thêm cột, thêm dòng.
- Tách và điền dữ liệu vào cột, dòng.
như file Excel (có 2 sheets: TH1, TH2).

Mình cám ơn rất nhiều.

 

[HieuCD]

Xin chào Anh, Chị, Em,

Hiện mình gặp vấn đề việc Tách dữ liệu nguồn (1 cột) thành các dữ liệu đích (nhiều cột) với nhiều dấu hiệu nhận biết khác nhau.
Hiện tại mình phải làm thủ công bằng cách chèn thêm cột rồi dùng các hàm trong Excel để tính.
Tuy nhiên do dữ liệu không đồng nhất nên trong cùng 1 cột lại phải dùng nhiều công thức khác nhau ở các dòng khác nhau.
Việc làm thủ công thao tác nhiều và lập đi lặp lại mỗi lần làm.

Xin nhờ Anh, Chị, Em xem giúp dùm mình có thể làm tự động (có thể bằng VBA):
- Tự động chèn thêm cột, thêm dòng.
- Tách và điền dữ liệu vào cột, dòng.
như file Excel (có 2 sheets: TH1, TH2).

Mình cám ơn rất nhiều.

Sub TachMain()
  Dim sArr(), tArr(), Res(), S, tmp As String
  Dim i As Long, n As Long, j As Long, k As Long, m As Long
  sArr = Range("B4", Range("B3").End(xlDown)).Value
  If InStr(1, sArr(1, 1), ";") Then
    ReDim Res(1 To UBound(sArr) * 10, 1 To 7)
    For i = 1 To UBound(sArr)
      tmp = sArr(i, 1)
      If Len(tmp) Then
        m = m + 1
        k = k + 1:      Res(k, 1) = m:    Res(k, 2) = tmp
        S = Split(tmp, ";")
        For n = 0 To UBound(S)
          tArr = TachText(S(n))
          k = k + 1
          Res(k, 3) = S(n)
          For j = 1 To 4
            Res(k, j + 3) = tArr(j)
          Next j
        Next n
      End If
    Next i
    Range("F10").Resize(k).NumberFormat = "@" 'Chinh lai vi tri tra ket qua
    Range("A10").Resize(k, 7) = Res 'Chinh lai vi tri tra ket qua
  Else
    ReDim Res(1 To UBound(sArr), 1 To 6)
    For i = 1 To UBound(sArr)
      tmp = sArr(i, 1)
      If Len(tmp) Then
        k = k + 1:      Res(k, 1) = k:    Res(k, 2) = tmp
        tArr = TachText(tmp)
        For j = 1 To 4
          Res(k, j + 2) = tArr(j)
        Next j
      End If
    Next i
    Range("E20").Resize(k).NumberFormat = "@" 'Chinh lai vi tri tra ket qua
    Range("A20").Resize(k, 6) = Res 'Chinh lai vi tri tra ket qua
  End If
End Sub

Private Function TachText(ByVal tmp As String)
  Dim Res(1 To 4), S, i As Long, j As Long, iNum As String
      
  If InStr(1, tmp, ". ") Then
    S = Split(tmp, ". ")
    Res(1) = S(0)
  Else
    S = Array(, tmp)
  End If

  tmp = S(1)
  If InStr(1, tmp, "(") Then
    S = Split(tmp, "(")
    Res(2) = S(0)
    S2 = Split(S(1) & " ", ")")
    tmp = S2(0)
    For j = 1 To Len(tmp)
      iNum = Mid(tmp, j, 1)
      If IsNumeric(iNum) Then Res(3) = Res(3) & iNum
    Next j
    Res(4) = Application.Trim(S2(1))
  Else
    For j = Len(tmp) To 1 Step -1
      iNum = Mid(tmp, j, 1)
      If IsNumeric(iNum) Then
        Res(4) = iNum & Res(4)
      Else
        Res(2) = Mid(tmp, 1, j)
        Exit For
      End If
    Next j
  End If
  TachText = Res
End Function

 

[duythanhmt]

Sub TachMain()
  Dim sArr(), tArr(), Res(), S, tmp As String
  Dim i As Long, n As Long, j As Long, k As Long, m As Long
  sArr = Range("B4", Range("B3").End(xlDown)).Value
  If InStr(1, sArr(1, 1), ";") Then
    ReDim Res(1 To UBound(sArr) * 10, 1 To 7)
    For i = 1 To UBound(sArr)
      tmp = sArr(i, 1)
      If Len(tmp) Then
        m = m + 1
        k = k + 1:      Res(k, 1) = m:    Res(k, 2) = tmp
        S = Split(tmp, ";")
        For n = 0 To UBound(S)
          tArr = TachText(S(n))
          k = k + 1
          Res(k, 3) = S(n)
          For j = 1 To 4
            Res(k, j + 3) = tArr(j)
          Next j
        Next n
      End If
    Next i
    Range("F10").Resize(k).NumberFormat = "@" 'Chinh lai vi tri tra ket qua
    Range("A10").Resize(k, 7) = Res 'Chinh lai vi tri tra ket qua
  Else
    ReDim Res(1 To UBound(sArr), 1 To 6)
    For i = 1 To UBound(sArr)
      tmp = sArr(i, 1)
      If Len(tmp) Then
        k = k + 1:      Res(k, 1) = k:    Res(k, 2) = tmp
        tArr = TachText(tmp)
        For j = 1 To 4
          Res(k, j + 2) = tArr(j)
        Next j
      End If
    Next i
    Range("E20").Resize(k).NumberFormat = "@" 'Chinh lai vi tri tra ket qua
    Range("A20").Resize(k, 6) = Res 'Chinh lai vi tri tra ket qua
  End If
End Sub

Private Function TachText(ByVal tmp As String)
  Dim Res(1 To 4), S, i As Long, j As Long, iNum As String
     
  If InStr(1, tmp, ". ") Then
    S = Split(tmp, ". ")
    Res(1) = S(0)
  Else
    S = Array(, tmp)
  End If

  tmp = S(1)
  If InStr(1, tmp, "(") Then
    S = Split(tmp, "(")
    Res(2) = S(0)
    S2 = Split(S(1) & " ", ")")
    tmp = S2(0)
    For j = 1 To Len(tmp)
      iNum = Mid(tmp, j, 1)
      If IsNumeric(iNum) Then Res(3) = Res(3) & iNum
    Next j
    Res(4) = Application.Trim(S2(1))
  Else
    For j = Len(tmp) To 1 Step -1
      iNum = Mid(tmp, j, 1)
      If IsNumeric(iNum) Then
        Res(4) = iNum & Res(4)
      Else
        Res(2) = Mid(tmp, 1, j)
        Exit For
      End If
    Next j
  End If
  TachText = Res
End Function

Thật sự cám ơn Anh HieuCD rất nhiều. Đó giờ tiếp xúc với Excel toàn các hàm cơ bản và đủ dùng trong công việc hàng ngày nên không chịu tìm tòi nghiên cứu. Bây giờ mới thấy VBA giúp ít thế nào trong công việc. Từ đây nhủ với lòng cố gắng học hỏi VBA và nâng cao kiến thức bản thân. Ông bà ta nói thật đúng "không tiến ắt lùi".