Trợ giúp code VBA. Copy dữ liệu từ Sheet1 này sang sheet2 có điều kiện cột.

[tuhumg00]

Mình có bài toán này muốn nhờ mọi code VBA. Giúp mình với nhé.
Mình muốn copy hoặc tìm dữ liệu từ từ Sheet1 sang Sheet2 theo điều kiện cột, dữ liệu của các cột (1,2a,3,4,ab) Sheet1 sẽ vào dữ liệu các cột tương ứng của Sheet2(cột Sheet2 đc xếp lộn xộn)( Theo như hình vẽ). Mình có thể làm với hàm index, match nhưng khi tìm ở 2 file excell khác nhau thì thì chỉ có cái đường link đôi lúc nó dài, và lúc kéo thả sợ nhầm lẫn...
Link file mình để bên dưới.
Xin cảm ơn các bạn rất nhiều.

Copy du lieu dung cot

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

 

[tuhumg00]

Tôi sửa luôn cho bài của bạn. Bài kia có thêm "râu ria" vì người ta muốn copy với điều kiện (nếu tôi nhớ không nhầm thì chỉ copy từ nguồn các dòng có Mã trong sheet2). Bài của bạn là copy đơn thuần - copy tất cả các dòng từ nguồn.
Cái mấu chốt vẫn là ý tưởng nhớ chỉ số cột của mỗi tiêu đề trong mảng nguồn vào dictionary. Sau đó duyệt từng tiêu đề trong mảng kết quả rồi tìm ra chỉ số cột của nó trong mảng nguồn - đọc từ dictionary. Sau đó thì copy cột có chỉ số được xác định từ mảng nguồn sang mảng kết quả. Thế thôi.

Sub copy()
Dim curr_row As Long, curr_col As Long, r As Long, c As Long, data(), result(), dic As Object, sh As Worksheet
    Set sh = ThisWorkbook.Worksheets("sheet2")
'    xoa du lieu cu o sheet2. Gia thiet la co nhieu nhat 100 000 dong va 100 Cot du lieu cu
    sh.Range("A3").Resize(100000, 100).ClearContents
'    lay du lieu tu sheet1 vao mang data
    With ThisWorkbook.Worksheets("sheet1")
'        dong cuoi cung co du lieu trong cot A
        curr_row = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc
        If curr_row < 3 Then Exit Sub
'        cot cuoi cung co tieu de o dong 2
        curr_col = .Cells(2, Columns.Count).End(xlToLeft).Column
'        lay du  lieu vao mang data
        data = .Range("A2").Resize(curr_row - 1, curr_col).Value
    End With
 
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
'    tieu de cot trong data voi tu cach la key va chi so cot cua no trong mang data voi tu cach la item
    For c = 1 To UBound(data, 2)
        If Not dic.exists(data(1, c)) Then dic.Add data(1, c), c
    Next c
'    xet sheet2
    With sh
'        cot cuoi cung co du lieu o dong 2 (tieu de)
        curr_col = .Cells(2, Columns.Count).End(xlToLeft).Column
'        mang result va mang data co cung so dong
        result = .Range("A2").Resize(UBound(data), curr_col).Value
    End With
'    duyet tung tieu de trong mang result (trong Sheet2)
    For c = 1 To UBound(result, 2)
'        neu tieu de co trong mang data thi thuc hien
        If dic.exists(result(1, c)) Then
'            doc tu dic ra chi so cot trong mang data cua tieu de hien hanh
            curr_col = dic.Item(result(1, c))
'            copy cot curr_col cua mang data sang cot c cua mang result
            For r = 2 To UBound(result)
                result(r, c) = data(r, curr_col)
            Next r
        End If
    Next c
'    nhap ket qua vao sheet2
    sh.Range("A2").Resize(UBound(result), UBound(result, 2)).Value = result
    Set dic = Nothing
End Sub

Em cảm ơn bác nhiều.hihi.đúng ý e rồi bác. chúc bác một ngày luôn vui vẻ. Xin được học bỏi bác nhiều.

 

[easport431991]

Tôi sửa luôn cho bài của bạn. Bài kia có thêm "râu ria" vì người ta muốn copy với điều kiện (nếu tôi nhớ không nhầm thì chỉ copy từ nguồn các dòng có Mã trong sheet2). Bài của bạn là copy đơn thuần - copy tất cả các dòng từ nguồn.
Cái mấu chốt vẫn là ý tưởng nhớ chỉ số cột của mỗi tiêu đề trong mảng nguồn vào dictionary. Sau đó duyệt từng tiêu đề trong mảng kết quả rồi tìm ra chỉ số cột của nó trong mảng nguồn - đọc từ dictionary. Sau đó thì copy cột có chỉ số được xác định từ mảng nguồn sang mảng kết quả. Thế thôi.

Sub copy()
Dim curr_row As Long, curr_col As Long, r As Long, c As Long, data(), result(), dic As Object, sh As Worksheet
    Set sh = ThisWorkbook.Worksheets("sheet2")
'    xoa du lieu cu o sheet2. Gia thiet la co nhieu nhat 100 000 dong va 100 Cot du lieu cu
    sh.Range("A3").Resize(100000, 100).ClearContents
'    lay du lieu tu sheet1 vao mang data
    With ThisWorkbook.Worksheets("sheet1")
'        dong cuoi cung co du lieu trong cot A
        curr_row = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc
        If curr_row < 3 Then Exit Sub
'        cot cuoi cung co tieu de o dong 2
        curr_col = .Cells(2, Columns.Count).End(xlToLeft).Column
'        lay du  lieu vao mang data
        data = .Range("A2").Resize(curr_row - 1, curr_col).Value
    End With
 
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
'    tieu de cot trong data voi tu cach la key va chi so cot cua no trong mang data voi tu cach la item
    For c = 1 To UBound(data, 2)
        If Not dic.exists(data(1, c)) Then dic.Add data(1, c), c
    Next c
'    xet sheet2
    With sh
'        cot cuoi cung co du lieu o dong 2 (tieu de)
        curr_col = .Cells(2, Columns.Count).End(xlToLeft).Column
'        mang result va mang data co cung so dong
        result = .Range("A2").Resize(UBound(data), curr_col).Value
    End With
'    duyet tung tieu de trong mang result (trong Sheet2)
    For c = 1 To UBound(result, 2)
'        neu tieu de co trong mang data thi thuc hien
        If dic.exists(result(1, c)) Then
'            doc tu dic ra chi so cot trong mang data cua tieu de hien hanh
            curr_col = dic.Item(result(1, c))
'            copy cot curr_col cua mang data sang cot c cua mang result
            For r = 2 To UBound(result)
                result(r, c) = data(r, curr_col)
            Next r
        End If
    Next c
'    nhap ket qua vao sheet2
    sh.Range("A2").Resize(UBound(result), UBound(result, 2)).Value = result
    Set dic = Nothing
End Sub

trường hợp 2 sheet ở 2 file khác nhau thì như thế nào bạn

 

[TongDe]

trường hợp 2 sheet ở 2 file khác nhau thì như thế nào bạn

Gán đoạn code này cho nút copy

Sub CopyByColumn()    'Copy to another sheet

Dim sArr As Variant  'Mang nguon
Dim rArr As Variant 'Mang dich
Dim tArr As Variant 'Mang chua cot copy
Dim i, j As Long

tArr = [{5,116,118,119,126,128,130,131,138,150,152,197,198,199,200}]
sArr = Workbooks("TongHop").Sheets("Data").[a1].CurrentRegion
ReDim rArr(1 To UBound(sArr), 1 To UBound(tArr))

    For i = 1 To UBound(sArr)
        For j = 1 To UBound(tArr)
            rArr(i, j) = sArr(i, tArr(j))
        Next j
    Next i

ThisWorkbook.Sheets("Sub").[A4].Resize(UBound(rArr), UBound(tArr)) = rArr

End Sub

 

[Hoàng Tuấn 868]

trường hợp 2 sheet ở 2 file khác nhau thì như thế nào bạn

Gán đoạn code này cho nút copy

Sub CopyByColumn()    'Copy to another sheet

Dim sArr As Variant  'Mang nguon
Dim rArr As Variant 'Mang dich
Dim tArr As Variant 'Mang chua cot copy
Dim i, j As Long

tArr = [{5,116,118,119,126,128,130,131,138,150,152,197,198,199,200}]
sArr = Workbooks("TongHop").Sheets("Data").[a1].CurrentRegion
ReDim rArr(1 To UBound(sArr), 1 To UBound(tArr))

    For i = 1 To UBound(sArr)
        For j = 1 To UBound(tArr)
            rArr(i, j) = sArr(i, tArr(j))
        Next j
    Next i

ThisWorkbook.Sheets("Sub").[A4].Resize(UBound(rArr), UBound(tArr)) = rArr

End Sub

Ở hai file khác nhau mà bạn ơi.

 

[TongDe]

Ở hai file khác nhau mà bạn ơi.

Copy 1 số cột từ sheet Data file Tong Hop , về Sheet Sub file Don Hang đó thây...