Tách chuỗi vào các cột tương ứng bằng VBA (1 người xem)

[thao nguyen01]

Kính gửi anh/chị,

Anh/chị xem giúp em vấn đề sau ạ: Em muốn lấy các mã giống nhau gom lại, nội dung sẽ tách thành các cột tương ứng ạ. Em có mô tả kết quả trong file ạ. Anh/chị xem giúp em ạ. Em cảm ơn anh/chị nhiều ạ.

 

[snow25]

Kính gửi anh/chị,

Anh/chị xem giúp em vấn đề sau ạ: Em muốn lấy các mã giống nhau gom lại, nội dung sẽ tách thành các cột tương ứng ạ. Em có mô tả kết quả trong file ạ. Anh/chị xem giúp em ạ. Em cảm ơn anh/chị nhiều ạ.

Thử.

Sub chuyendulieu()
    Dim arr, i As Long, lr As Long, dic As Object, a As Long, b As Long, dk As String, c As Long, d As Long
    d = 2
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To UBound(arr))
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = dk
                kq(a, 2) = arr(i, 2)
                dic.Add (dk), Array(a, 2)
             Else
                b = dic.Item(dk)(0)
                c = dic.Item(dk)(1) + 1
                kq(b, c) = arr(i, 2)
                dic.Item(dk) = Array(b, c)
                If d < c Then d = c
             End If
         Next i
         .Range("E3:k100").ClearContents
         .Range("e3").Resize(a, d).Value = kq
  End With
End Sub

 

[Tuan_hcth]

Thử.

Sub chuyendulieu()
    Dim arr, i As Long, lr As Long, dic As Object, a As Long, b As Long, dk As String, c As Long, d As Long
    d = 2
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To UBound(arr))
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = dk
                kq(a, 2) = arr(i, 2)
                dic.Add (dk), Array(a, 2)
             Else
                b = dic.Item(dk)(0)
                c = dic.Item(dk)(1) + 1
                kq(b, c) = arr(i, 2)
                dic.Item(dk) = Array(b, c)
                If d < c Then d = c
             End If
         Next i
         .Range("E3:k100").ClearContents
         .Range("e3").Resize(a, d).Value = kq
  End With
End Sub

dic.Add (dk), Array(a, 2)
Else
b = dic.Item(dk)(0)
c = dic.Item(dk)(1) + 1
kq(b, c) = arr(i, 2)
dic.Item(dk) = Array(b, c)
Bác có thể giải thích giúp em đoạn code này được không ạ? Thanks bác

 

[thao nguyen01]

Thử.

Sub chuyendulieu()
    Dim arr, i As Long, lr As Long, dic As Object, a As Long, b As Long, dk As String, c As Long, d As Long
    d = 2
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To UBound(arr))
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = dk
                kq(a, 2) = arr(i, 2)
                dic.Add (dk), Array(a, 2)
             Else
                b = dic.Item(dk)(0)
                c = dic.Item(dk)(1) + 1
                kq(b, c) = arr(i, 2)
                dic.Item(dk) = Array(b, c)
                If d < c Then d = c
             End If
         Next i
         .Range("E3:k100").ClearContents
         .Range("e3").Resize(a, d).Value = kq
  End With
End Sub

Dạ, kết quả ra đúng ạ. Em cảm ơn anh nhiều ạ. Nhưng anh có thể giải thích giúp em đoạn code sau không ạ:

1. dic.Add (dk), Array(a, 2)
Em viết lại dic.add(dk),arr(a,2) thì báo lỗi ạ?

2. Và 2 dòng code này luôn ạ:
b = dic.Item(dk)(0)
c = dic.Item(dk)(1) + 1

Em không hiểu tại sao lại có (0) và (1) ở sau ạ? Em cảm ơn anh ạ.

 

[VetMini]

Tại vì mỗi item là một mảng 2 phần tử: (0) là phần tử thứ nhất và (1) là phần tử thứ hai.

Xem đoạn code này:
dic.Add (dk), Array(a, 2) ' ghi vào dic: key là dk, và item là mảng 2 phần tử với trị a và 2
và đoạn này:
dic.Item(dk) = Array(b, c) ' chỉnh dic: lôi item có key là dk ra, chỉnh thành mảng với 2 phần tử là b và c

 

[thao nguyen01]

Tại vì mỗi item là một mảng 2 phần tử: (0) là phần tử thứ nhất và (1) là phần tử thứ hai.

Xem đoạn code này:
dic.Add (dk), Array(a, 2) ' ghi vào dic: key là dk, và item là mảng 2 phần tử với trị a và 2
và đoạn này:
dic.Item(dk) = Array(b, c) ' chỉnh dic: lôi item có key là dk ra, chỉnh thành mảng với 2 phần tử là b và c

Dạ, em cảm ơn Thầy @VetMini nhiều ạ. Em có thắc mắc ở đoạn code:
1. kq(b, c) = arr(i, 2)
2. dic.Item(dk) = Array(b, c)
If d < c Then d = c
Em chưa hiểu là sao dòng code số 1 lại có trước dòng số 2 ạ: Em nghĩ là dic.item(dk)=array(b,c) có trước, sau đó array(b,c) tức kq(b,c) sẽ lấy giá trị từ arr(i,2) ạ?

Và khi d<c thì cho d=c, em ví dụ nếu d=2, c=3 thì 2<3, thì lúc đó d=c là bằng 3 đúng không ạ?

Vì em mới tìm hiểu về VBA nên chưa hiểu lắm ạ. Thầy có thể giải thích giúp em với ạ. Em cảm ơn Thầy ạ.

 

[VetMini]

Dạ, em cảm ơn Thầy @VetMini nhiều ạ. Em có thắc mắc ở đoạn code:
1. kq(b, c) = arr(i, 2)
2. dic.Item(dk) = Array(b, c)
If d < c Then d = c
Em chưa hiểu là sao dòng code số 1 lại có trước dòng số 2 ạ: Em nghĩ là dic.item(dk)=array(b,c) có trước, sau đó array(b,c) tức kq(b,c) sẽ lấy giá trị từ arr(i,2) ạ?
...

Hai cái dòng 1 và 2 đâu có liên quan gì nhau. Cái nào trước lại chẳng được.
dòng 1 gán trị cho kq
dòng 2 gán trị cho item của dic
dòng thứ ba xác định cột cuối được sử dụng trong mảng kq

Thực tế mà nói thì người viết code viết theo thói quen chỉ chữa cháy vấn đề. Loại code này bạn cứ việc thẳng thừng copy về mà chạy. Để hiểu được nó còn phải qua nhiều nổ lực.

 

[thao nguyen01]

Hai cái dòng 1 và 2 đâu có liên quan gì nhau. Cái nào trước lại chẳng được.
dòng 1 gán trị cho kq
dòng 2 gán trị cho item của dic
dòng thứ ba xác định cột cuối được sử dụng trong mảng kq

Thực tế mà nói thì người viết code viết theo thói quen chỉ chữa cháy vấn đề. Loại code này bạn cứ việc thẳng thừng copy về mà chạy. Để hiểu được nó còn phải qua nhiều nổ lực.

Dạ, em cảm ơn Thầy @VetMini nhiều ạ.