RÚT TRÍCH TRẢ VỀ KẾT QUẢ

khkkh · 24/4/20

Chào cả nhà
Hôm nay mình lại đang vật lộn với bài toán khó.
Mình muốn rút trích cho gon dữ liệu và nhanh(làm thủ công mất thời gian)
Mọi người xem file đính kèm giúp mình CODE VBA nhé.
(Trong file có 3 sheet chỉ quan tâm đến sheet TA_NGUON Và TA_KQ => Kết quả mong muốn ở sheet TA_KQ)
Xin cảm ơn

HieuCD · 24/4/20

SEAHAI đã viết:
Chào cả nhà
Hôm nay mình lại đang vật lộn với bài toán khó.
Mình muốn rút trích cho gon dữ liệu và nhanh(làm thủ công mất thời gian)
Mọi người xem file đính kèm giúp mình CODE VBA nhé.
(Trong file có 3 sheet chỉ quan tâm đến sheet TA_NGUON Và TA_KQ => Kết quả mong muốn ở sheet TA_KQ)
Xin cảm ơn

Xét các số liên tiếp phải nằm kế bên nhau

Mã:

Sub ABC()
  Dim sArr(), Res(), Arr, Dic As Object, iKey
  Dim sRow&, i&, r&, k&, tmp&
  With Sheets("TA_NGUON")
    sArr = .Range("C2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 2)
  Set Dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    iKey = sArr(i, 1)
    tmp = sArr(i, 2)
    If Dic.exists(iKey) = False Then
      k = k + 1
      Res(k, 1) = iKey
      Dic.Add iKey, Array(k, tmp, tmp)
    Else
      Arr = Dic.Item(iKey)
      r = Arr(0)
      If tmp = Arr(2) + 1 Then
        Arr(2) = tmp
      Else
        If Arr(1) = Arr(2) Then
          Res(r, 2) = Res(r, 2) & "," & Arr(1)
        Else
          Res(r, 2) = Res(r, 2) & "," & Arr(1) & "->" & Arr(2)
        End If
        Arr(1) = tmp: Arr(2) = tmp
      End If
      Dic.Item(iKey) = Arr
    End If
  Next i
  For Each iKey In Dic.keys
    Arr = Dic.Item(iKey)
    r = Arr(0)
    If Arr(1) = Arr(2) Then
      Res(r, 2) = Res(r, 2) & "," & Arr(1)
    Else
      Res(r, 2) = Res(r, 2) & "," & Arr(1) & "->" & Arr(2)
    End If
    Res(r, 2) = Mid(Res(r, 2), 2, Len(Res(r, 2)))
  Next
  Sheets("TA_KQ").Range("A2").Resize(k, 2) = Res
End Sub

CHAOQUAY · 25/4/20

SEAHAI đã viết:
Chào cả nhà
Hôm nay mình lại đang vật lộn với bài toán khó.
Mình muốn rút trích cho gon dữ liệu và nhanh(làm thủ công mất thời gian)
Mọi người xem file đính kèm giúp mình CODE VBA nhé.
(Trong file có 3 sheet chỉ quan tâm đến sheet TA_NGUON Và TA_KQ => Kết quả mong muốn ở sheet TA_KQ)
Xin cảm ơn

Giả định các số liên tiếp được xếp tuần tự từ trên xuống

Mã:

Sub Ghep()
Dim Nguon, Tam, Mang0, Mang1
Dim Kq
Dim i, j, k
Nguon = Sheet1.Range("A1").CurrentRegion
With CreateObject("Scripting.Dictionary")
    ReDim Mang0(UBound(Nguon))
    For i = 2 To UBound(Nguon)
        If .exists(Nguon(i, 3)) = 0 Then
            Mang0(0) = Nguon(i, 4)
            .Item(Nguon(i, 3)) = Array(Nguon(i, 4), 0, Mang0)
        Else
            Mang1 = .Item(Nguon(i, 3))
            Tam = Mang1(2)
            If Nguon(i, 4) = Mang1(0) + 1 Then
                If IsArray(Tam(Mang1(1))) Then
                    Tam(Mang1(1))(2) = Nguon(i, 4)
                Else
                    j = Tam(Mang1(1))
                    Tam(Mang1(1)) = Array(j, "->", Nguon(i, 4))
                End If
            Else
                If IsArray(Tam(Mang1(1))) Then
                    Tam(Mang1(1))(2) = Mang1(0)
                End If
                Mang1(1) = Mang1(1) + 1
                Tam(Mang1(1)) = Nguon(i, 4)
            End If
            Mang1(0) = Nguon(i, 4)
            Mang1(2) = Tam
            .Item(Nguon(i, 3)) = Mang1
        End If
    Next i
    ReDim Kq(1 To .Count, 1 To 2)
    k = 0
    For Each i In .keys
        k = k + 1
        Kq(k, 1) = i
        Tam = .Item(i)(2)
        For j = 0 To UBound(Tam)
            If IsArray(Tam(j)) Then Tam(j) = Replace(Join(Tam(j)), " ", "")
            If Tam(j) = "" Then Exit For
        Next j
        Kq(k, 2) = Replace(Trim(Join(Tam)), " ", ", ")
    Next i
End With
Sheet2.Range("F2").Resize(UBound(Kq), 2) = Kq
End Sub

khkkh · 25/4/20

CHAOQUAY đã viết:

Giả định các số liên tiếp được xếp tuần tự từ trên xuống

Mã:

Sub Ghep()
Dim Nguon, Tam, Mang0, Mang1
Dim Kq
Dim i, j, k
Nguon = Sheet1.Range("A1").CurrentRegion
With CreateObject("Scripting.Dictionary")
    ReDim Mang0(UBound(Nguon))
    For i = 2 To UBound(Nguon)
        If .exists(Nguon(i, 3)) = 0 Then
            Mang0(0) = Nguon(i, 4)
            .Item(Nguon(i, 3)) = Array(Nguon(i, 4), 0, Mang0)
        Else
            Mang1 = .Item(Nguon(i, 3))
            Tam = Mang1(2)
            If Nguon(i, 4) = Mang1(0) + 1 Then
                If IsArray(Tam(Mang1(1))) Then
                    Tam(Mang1(1))(2) = Nguon(i, 4)
                Else
                    j = Tam(Mang1(1))
                    Tam(Mang1(1)) = Array(j, "->", Nguon(i, 4))
                End If
            Else
                If IsArray(Tam(Mang1(1))) Then
                    Tam(Mang1(1))(2) = Mang1(0)
                End If
                Mang1(1) = Mang1(1) + 1
                Tam(Mang1(1)) = Nguon(i, 4)
            End If
            Mang1(0) = Nguon(i, 4)
            Mang1(2) = Tam
            .Item(Nguon(i, 3)) = Mang1
        End If
    Next i
    ReDim Kq(1 To .Count, 1 To 2)
    k = 0
    For Each i In .keys
        k = k + 1
        Kq(k, 1) = i
        Tam = .Item(i)(2)
        For j = 0 To UBound(Tam)
            If IsArray(Tam(j)) Then Tam(j) = Replace(Join(Tam(j)), " ", "")
            If Tam(j) = "" Then Exit For
        Next j
        Kq(k, 2) = Replace(Trim(Join(Tam)), " ", ", ")
    Next i
End With
Sheet2.Range("F2").Resize(UBound(Kq), 2) = Kq
End Sub

Thanks bạn nhiều nha

Bài đã được tự động gộp: 25/4/20

HieuCD đã viết:

Xét các số liên tiếp phải nằm kế bên nhau

Mã:

Sub ABC()
  Dim sArr(), Res(), Arr, Dic As Object, iKey
  Dim sRow&, i&, r&, k&, tmp&
  With Sheets("TA_NGUON")
    sArr = .Range("C2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 2)
  Set Dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    iKey = sArr(i, 1)
    tmp = sArr(i, 2)
    If Dic.exists(iKey) = False Then
      k = k + 1
      Res(k, 1) = iKey
      Dic.Add iKey, Array(k, tmp, tmp)
    Else
      Arr = Dic.Item(iKey)
      r = Arr(0)
      If tmp = Arr(2) + 1 Then
        Arr(2) = tmp
      Else
        If Arr(1) = Arr(2) Then
          Res(r, 2) = Res(r, 2) & "," & Arr(1)
        Else
          Res(r, 2) = Res(r, 2) & "," & Arr(1) & "->" & Arr(2)
        End If
        Arr(1) = tmp: Arr(2) = tmp
      End If
      Dic.Item(iKey) = Arr
    End If
  Next i
  For Each iKey In Dic.keys
    Arr = Dic.Item(iKey)
    r = Arr(0)
    If Arr(1) = Arr(2) Then
      Res(r, 2) = Res(r, 2) & "," & Arr(1)
    Else
      Res(r, 2) = Res(r, 2) & "," & Arr(1) & "->" & Arr(2)
    End If
    Res(r, 2) = Mid(Res(r, 2), 2, Len(Res(r, 2)))
  Next
  Sheets("TA_KQ").Range("A2").Resize(k, 2) = Res
End Sub

Thanks bạn nhiều nha

RÚT TRÍCH TRẢ VỀ KẾT QUẢ

khkkh

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

CHAOQUAY

Thành viên gắn bó

khkkh

Thành viên mới

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