Tách Dữ Liệu Ra nhiều Cột

phuoclocvl · 5/6/21

Chào Các Anh Chị Diễn Đàn,
Em cũng không biết dặt tiêu đề sao cho phù hợp nữa, em diễn giải sơ qua nhớ các anh chị giúp giùm,
Vốn là em muốn dùng dictionary thay cho VLookup. nhưng lấy 1 lúc nhiều cột. nhưng em không biết làm cách nào để nó đưa vào từng ô mà chỉ gộp 1 ô như hình.
Các anh chị xem giúp em vấn đề này với nha.
Cảm ơn các anh chị nhiều,

và đây là code của em. có trong file đính kèm

PHP:

Sub TestDic()
    Dim i As Integer, eRow As Integer, Tmp As String
    Dim shData As Worksheet: Set shData = ThisWorkbook.Sheets("Data"): Dim shKq As Worksheet: Set shKq = ThisWorkbook.Sheets("KQ")
    Dim sArr(), rArr() As String, k As Integer, Col As Integer
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
      'Dic.CompareMode = vbTextCompare
    With shData
        Col = .Range("A1").End(xlToRight).Column
        If Col > 1000 Then Exit Sub
        eRow = .Range("A1000").End(xlUp).Row
        sArr = .Range("A1:d" & eRow).Value
        For i = 1 To UBound(sArr, 1)
            Tmp = sArr(i, 1)
            Dic(Tmp) = sArr(i, 2) & Chr(44) & sArr(i, 3) & Chr(44) & sArr(i, 4)
        Next i
    End With
    Tmp = ""
    Erase sArr
    
    With shKq
        eRow = .Range("A1000").End(xlUp).Row
        If eRow < 3 Then Exit Sub
        sArr = .Range("A3:A" & eRow).Value
        ReDim rArr(1 To UBound(sArr, 1), 1 To 1)
        
        For i = 1 To UBound(sArr, 1)
            Tmp = sArr(i, 1)
            k = k + 1
            rArr(k, 1) = Dic(Tmp)
        Next i
            .Range("B3:B" & eRow).ClearContents
            .Range("B3").Resize(k, 1) = rArr
    End With
    
    Set Dic = Nothing
    Erase rArr
    Erase sArr
End Sub

Nhattanktnn · 5/6/21

phuoclocvl đã viết:
Chào Các Anh Chị Diễn Đàn,
Em cũng không biết dặt tiêu đề sao cho phù hợp nữa, em diễn giải sơ qua nhớ các anh chị giúp giùm,
Vốn là em muốn dùng dictionary thay cho VLookup. nhưng lấy 1 lúc nhiều cột. nhưng em không biết làm cách nào để nó đưa vào từng ô mà chỉ gộp 1 ô như hình.
Các anh chị xem giúp em vấn đề này với nha.
Cảm ơn các anh chị nhiều,

và đây là code của em. có trong file đính kèm

PHP:

Sub TestDic() Dim i As Integer, eRow As Integer, Tmp As String Dim shData As Worksheet: Set shData = ThisWorkbook.Sheets("Data"): Dim shKq As Worksheet: Set shKq = ThisWorkbook.Sheets("KQ") Dim sArr(), rArr() As String, k As Integer, Col As Integer Dim Dic As Object Set Dic = CreateObject("Scripting.Dictionary") 'Dic.CompareMode = vbTextCompare With shData Col = .Range("A1").End(xlToRight).Column If Col > 1000 Then Exit Sub eRow = .Range("A1000").End(xlUp).Row sArr = .Range("A1:d" & eRow).Value For i = 1 To UBound(sArr, 1) Tmp = sArr(i, 1) Dic(Tmp) = sArr(i, 2) & Chr(44) & sArr(i, 3) & Chr(44) & sArr(i, 4) Next i End With Tmp = "" Erase sArr With shKq eRow = .Range("A1000").End(xlUp).Row If eRow < 3 Then Exit Sub sArr = .Range("A3:A" & eRow).Value ReDim rArr(1 To UBound(sArr, 1), 1 To 1) For i = 1 To UBound(sArr, 1) Tmp = sArr(i, 1) k = k + 1 rArr(k, 1) = Dic(Tmp) Next i .Range("B3:B" & eRow).ClearContents .Range("B3").Resize(k, 1) = rArr End With Set Dic = Nothing Erase rArr Erase sArr End Sub

View attachment 260093

Dùng Dictionary thì thường liên tưởng đến lấy giá trị duy nhất theo key. Nhưng dữ liệu bạn đưa lên thì cái cột Item# nó lại không có mã nào trùng nhau. Vậy nếu dữ liệu nhiều thì Item có trùng nhau không? và nếu có trùng nhau thì các giá trị trên cùng một cột Vendor sẽ nối lại với nhau hay như thế nào?

phuoclocvl · 5/6/21

Nhattanktnn đã viết:
Dùng Dictionary thì thường liên tưởng đến lấy giá trị duy nhất theo key. Nhưng dữ liệu bạn đưa lên thì cái cột Item# nó lại không có mã nào trùng nhau. Vậy nếu dữ liệu nhiều thì Item có trùng nhau không? và nếu có trùng nhau thì các giá trị trên cùng một cột Vendor sẽ nối lại với nhau hay như thế nào?

Chào anh,

Sheet Data là chứa dữ liệu cần lấy.
Sheet KQ là chỉ có 1 cột là Item ở cột A.
em muốn lấy qua bên sheet KQ 3 cột B, C, và D những cũng thành 3 cột như bên Sheet Data. với dữ liệu em lấy thì nó dồn và 1 cột. em không biết làm cách nào để tách nó ra thành 3 cột. anh chỉ em cách làm cho dữ liệu tách thành 3 cột ra giúp với.

Nhattanktnn · 5/6/21

phuoclocvl đã viết:
Chào anh,

Sheet Data là chứa dữ liệu cần lấy.
Sheet KQ là chỉ có 1 cột là Item ở cột A.
em muốn lấy qua bên sheet KQ 3 cột B, C, và D những cũng thành 3 cột như bên Sheet Data. với dữ liệu em lấy thì nó dồn và 1 cột. em không biết làm cách nào để tách nó ra thành 3 cột. anh chỉ em cách làm cho dữ liệu tách thành 3 cột ra giúp với.

View attachment 260099

Bạn không hiểu ý mình nhỉ. Dữ liệu nguồn có trường hợp như thế này không?

phuoclocvl · 5/6/21

Nhattanktnn đã viết:
Bạn không hiểu ý mình nhỉ. Dữ liệu nguồn có trường hợp như thế này không?
View attachment 260100

không có anh, chỉ 1:1 thôi

Nhattanktnn · 5/6/21

phuoclocvl đã viết:
không có anh, chỉ 1:1 thôi

Vậy thì đâu cần dictionary

Mã:

Sub GetData()
Dim sArr(), dArr(), I As Long, J As Long, K As Long
sArr = Sheets("Data").Range("A1:D" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row).Value
dArr = Sheets("KQ").Range("E3:H" & Sheets("KQ").Cells(Rows.Count, "E").End(xlUp).Row).Value
For I = 1 To UBound(dArr)
    For J = 1 To UBound(sArr)
        If sArr(J, 1) = dArr(I, 1) Then
            For K = 2 To 4
                dArr(I, K) = sArr(J, K)
            Next
            Exit For
        End If
    Next
Next
Sheets("KQ").Range("E3:H" & 2 + UBound(dArr)) = dArr
End Sub

adua29 · 5/6/21

Số cột sheet KQ tương ứng với số cột sheet data, vậy chỉ cần copy rồi paste link là không được sao

phuoclocvl · 5/6/21

adua29 đã viết:
Số cột sheet KQ tương ứng với số cột sheet data, vậy chỉ cần copy rồi paste link là không được sao

nhưng nếu dữ liệu không đúng theo như bên sheet KQ, copy paste là ăn cho hết luôn bác. cái này là ví dụ thôi, thực tế không đẹp như trong film đâu haha

Bài đã được tự động gộp: 5/6/21

Nhattanktnn đã viết:

Vậy thì đâu cần dictionary

Mã:

Sub GetData()
Dim sArr(), dArr(), I As Long, J As Long, K As Long
sArr = Sheets("Data").Range("A1:D" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row).Value
dArr = Sheets("KQ").Range("E3:H" & Sheets("KQ").Cells(Rows.Count, "E").End(xlUp).Row).Value
For I = 1 To UBound(dArr)
    For J = 1 To UBound(sArr)
        If sArr(J, 1) = dArr(I, 1) Then
            For K = 2 To 4
                dArr(I, K) = sArr(J, K)
            Next
            Exit For
        End If
    Next
Next
Sheets("KQ").Range("E3:H" & 2 + UBound(dArr)) = dArr
End Sub

Cảm ơn Anh rất nhìu, code rất chính xác, em cũng thử theo kiểu người nghĩ sao làm vậy nên em quất thêm 2 cái Dic nữa haha

PHP:

Option Explicit

Sub TestDic()
    Dim I As Integer, eRow As Integer, Tmp As String
    Dim shData As Worksheet: Set shData = ThisWorkbook.Sheets("Data"): Dim shKq As Worksheet: Set shKq = ThisWorkbook.Sheets("KQ")
    Dim sArr(), rArr() As String, K As Integer, Col As Integer
    Dim Dic As Object, Dic1 As Object, Dic2 As Object
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
      'Dic.CompareMode = vbTextCompare
    With shData
        Col = .Range("A1").End(xlToRight).Column
        If Col > 1000 Then Exit Sub
        eRow = .Range("A1000").End(xlUp).Row
        sArr = .Range("A1:d" & eRow).Value
        For I = 1 To UBound(sArr, 1)
            Tmp = sArr(I, 1)
            Dic(Tmp) = sArr(I, 2)
            Dic1(Tmp) = sArr(I, 3)
            Dic2(Tmp) = sArr(I, 4)
        Next I
    End With
    Tmp = ""
    Erase sArr
    
    With shKq
        eRow = .Range("A1000").End(xlUp).Row
        If eRow < 3 Then Exit Sub
        sArr = .Range("A3:D" & eRow).Value
        ReDim rArr(1 To UBound(sArr, 1), 1 To 3)
        
        For I = 1 To UBound(sArr, 1)
            Tmp = sArr(I, 1)
            K = K + 1
            rArr(K, 1) = Dic(Tmp)
            rArr(K, 2) = Dic1(Tmp)
            rArr(K, 3) = Dic2(Tmp)
        Next I
            .Range("B3:B" & eRow).ClearContents
            .Range("B3").Resize(K, 3) = (rArr)
    End With
    
    Set Dic = Nothing
    Set Dic1 = Nothing
    Set Dic2 = Nothing
    Erase rArr
    Erase sArr
End Sub

Tách Dữ Liệu Ra nhiều Cột

phuoclocvl

Thành viên thường trực

File đính kèm

Nhattanktnn

Thành viên gắn bó

phuoclocvl

Thành viên thường trực

Nhattanktnn

Thành viên gắn bó

phuoclocvl

Thành viên thường trực

Nhattanktnn

Thành viên gắn bó

adua29

Real-life Girls Super Сasual Dating

phuoclocvl

Thành viên thường trực

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