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

Liên hệ QC
P

phuoclocvl

Thành viên thường trực
Tham gia
28/3/12
Bài viết
220
Được thích
32
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

1622864024648.png
 

File đính kèm

  • Help.xlsm
    23.6 KB · Đọc: 12
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
Nhấp chuột vào đây để mở rộng...
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?
 
Upvote 0
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?
Nhấp chuột vào đây để mở rộng...
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.


1622870251899.png
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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?
1622870688883.png
 
Upvote 0
phuoclocvl đã viết:
không có anh, chỉ 1:1 thôi
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
 
Upvote 0
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ấp chuột vào đây để mở rộng...
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:

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
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
20
Đọc
329
shnhatha221108
S
S
Slicer không chuyển qua trạng thái mờ.
Trả lời
1
Đọc
30
ptm0412
ptm0412
K
Vẽ biểu đồ ứng suất bản thân và ứng suất gây lún = Excel
    • Thích
Trả lời
5
Đọc
13K
ptm0412
ptm0412
M
Bảng Pivot ko tự update theo dữ liệu và còn cộng thiếu số liệu.
Trả lời
6
Đọc
60
ptm0412
ptm0412
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
36
Đọc
472
hoangtran1176
hoangtran1176
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom