[Help] Xử lý mảng dữ liệu hàng thành cột (2 người xem)

[kohlerbkqn]

Mình cần xử lý mảng dữ liệu hàng thành cột như sau, vì số lượng mảng lớn nên không thể làm thủ công bằng lệnh transpone Mong mọi người giúp đỡ. Thanks

 

[Ba Tê]

Mình cần xử lý mảng dữ liệu hàng thành cột như sau, vì số lượng mảng lớn nên không thể làm thủ công bằng lệnh transpone Mong mọi người giúp đỡ. ThanksView attachment 129032

Tặng bạn code "XiMaChao" này, nếu topic này không "bị gì..."

Public Sub XiMaChao()
Dim Dic As Object, sArr(), dArr(), I As Long, CoL As Long, MaxCoL As Long, K As Long, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([A3], [B3].End(xlDown)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 255)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then
        K = K + 1: CoL = 3
        Dic.Add Tem, K
        dArr(K, 1) = CoL
        dArr(K, 2) = Tem
        dArr(K, CoL) = sArr(I, 2)
    Else
        CoL = dArr(Dic.Item(Tem), 1) + 1
        If CoL > MaxCoL Then MaxCoL = CoL
        dArr(Dic.Item(Tem), 1) = CoL
        dArr(Dic.Item(Tem), CoL) = sArr(I, 2)
    End If
Next I
[D3].Resize(K, MaxCoL) = dArr
[D3].Resize(K).ClearContents
Set Dic = Nothing
End Sub

 

[kohlerbkqn]

Cám ơn bạn Ba Tê. Bạn có thể kiểm tra giúp được không, mình cho vào Macro -> module nhưng bị báo lỗi.

Mình gởi lại file, nhờ bạn add giúp với. Thanks

 

[Ba Tê]

Cám ơn bạn Ba Tê. Bạn có thể kiểm tra giúp được không, mình cho vào Macro -> module nhưng bị báo lỗi.

Mình gởi lại file, nhờ bạn add giúp với. Thanks

1/ Phải lưu file kiểu .xlsm mới sử dụng VBA được, xlsx là thua.
2/ Khi mở file phải Enable Macros. (tìm trên GPE cách Enable Macros với Excel của bạn)

 

[Quang_Hải]

Chới khác kiểu của anh Ba Tê tí coi có tê hơn tí nào hay không

Sub BuaXua()
Dim Data(), Res(), tmp As Variant
Dim I As Long, CoL As Long, x As Long, y As Long, k As Long
Data = Range([A3], [B3].End(xlDown)).Value
ReDim Res(1 To UBound(Data), 1 To 255)
With CreateObject("Scripting.Dictionary")
   For I = 1 To UBound(Data, 1)
      tmp = Data(I, 1)
       If Not .Exists(tmp) Then
           k = k + 1
           .Add Data(I, 1), k
           Res(k, 1) = tmp
           Res(k, 2) = Data(I, 2)
       Else
            x = .Item(Data(I, 1))
            For y = 3 To UBound(Res, 2)
               If Res(x, y) = Empty Then
                  Res(x, y) = Data(I, 2)
                  CoL = IIf(y > CoL, y, CoL)
                  Exit For
               End If
            Next
       End If
   Next I
End With
[E3].Resize(k, CoL) = Res
End Sub

 

[ndu96081631]

Chới khác kiểu của anh Ba Tê tí coi có tê hơn tí nào hay không

Chơi tiếp kiểu khác nữa:

Sub Transfer(ByVal Field_1 As Range, ByVal Field_2 As Range, ByVal Target As Range)
  Dim aField_1, aField_2, aColPos(), Arr(), tmp1, tmp2
  Dim i As Long, lR As Long, lC As Long, lMaxCol As Long
  aField_1 = Field_1.Value
  aField_2 = Field_2.Value
  lMaxCol = 2
  ReDim Arr(1 To UBound(aField_1, 1), 1 To lMaxCol)
  ReDim aColPos(1 To UBound(aField_1, 1))
  With CreateObject("Scripting.Dictionary")
    For i = LBound(aField_1, 1) To UBound(aField_1, 1)
      tmp1 = CStr(aField_1(i, 1))
      If Len(tmp1) Then
        tmp2 = CStr(aField_2(i, 1))
        If Not .Exists(tmp1) Then
          lR = lR + 1
          .Add tmp1, lR
          Arr(lR, 1) = tmp1
          Arr(lR, 2) = tmp2
          aColPos(lR) = 2
        Else
          aColPos(.Item(tmp1)) = aColPos(.Item(tmp1)) + 1
          lC = aColPos(.Item(tmp1))
          If lMaxCol < lC Then lMaxCol = lC
          ReDim Preserve Arr(1 To UBound(aField_1, 1), 1 To lMaxCol)
          Arr(.Item(tmp1), lC) = tmp2
        End If
      End If
    Next
  End With
  If lR Then Target.Resize(lR, lMaxCol).Value = Arr
End Sub

Sub Main()
  Dim Field_1 As Range, Field_2 As Range, Target As Range
  Set Field_1 = Range("A3:A10000")
  Set Field_2 = Range("B3:B10000")
  Set Target = Range("E3")
  Transfer Field_1, Field_2, Target
End Sub

Chỉ quan tâm đến sub Main và áp dụng, còn Sub Transfer ở trên thế nào thây kệ nó
Ẹc... Ẹc...

 

[kohlerbkqn]

Cám ơn các anh chị rất nhiều.::

 

[diepminhhong]

Anh ơi anh giúp em viết đoạn code này được k ạ? E cảm ơn anh nhiều! E thấy đoạn code anh viết bên trên hay quá. Về khoản này e ngu ngơ k biết gì, chuyển ngang dọc toàn phải làm thủ công bằng lệnh Tranpose. Vì số lượng nhiều nên cop to tay mà k xong được. Mong hồi âm của anh!!!

 

[diepminhhong]

Tặng bạn code "XiMaChao" này, nếu topic này không "bị gì..."

Public Sub XiMaChao()
Dim Dic As Object, sArr(), dArr(), I As Long, CoL As Long, MaxCoL As Long, K As Long, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([A3], [B3].End(xlDown)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 255)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then
        K = K + 1: CoL = 3
        Dic.Add Tem, K
        dArr(K, 1) = CoL
        dArr(K, 2) = Tem
        dArr(K, CoL) = sArr(I, 2)
    Else
        CoL = dArr(Dic.Item(Tem), 1) + 1
        If CoL > MaxCoL Then MaxCoL = CoL
        dArr(Dic.Item(Tem), 1) = CoL
        dArr(Dic.Item(Tem), CoL) = sArr(I, 2)
    End If
Next I
[D3].Resize(K, MaxCoL) = dArr
[D3].Resize(K).ClearContents
Set Dic = Nothing
End Sub

Anh ơi anh giúp em viết đoạn code này được k ạ? E cảm ơn anh nhiều! E thấy đoạn code anh viết bên trên hay quá. Về khoản này e ngu ngơ k biết gì, chuyển ngang dọc toàn phải làm thủ công bằng lệnh Tranpose. Vì số lượng nhiều nên cop to tay mà k xong được. Mong hồi âm của anh!!!