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

 

[AnhThu-1976]

Option Explicit

Sub Loc()
    Dim Data As Variant, kQarr As Variant
    Dim lR As Long, k As Long, i As Long

    With Sheets("Sheet1")
        Data = .Range(.[A3], .[A65000].End(xlUp)).Resize(, 5)
    End With
    lR = UBound(Data)
    ReDim kQarr(1 To lR, 1 To 5)
    For i = 1 To UBound(Data)
        If Len(Data(i, 1)) Then
            k = k + 1
            kQarr(k, 1) = Data(i, 1)
            kQarr(k, 2) = Data(i, 3)
            kQarr(k, 3) = Data(i, 2)
            kQarr(k, 4) = Data(i, 5)
            kQarr(k, 5) = Data(i, 4)
        End If
    Next i
    Sheets("sheet2").Range("A3:E10000").ClearContents
    Sheets("sheet2").[A3].Resize(k, 5) = kQarr
End Sub

 

[AnhThu-1976]

1/ Thêm bẫy lỗi trường hợp Sheet1: không có dữ liệu
2/ Code dưới sẽ xóa số liệu cũ từ

Sheets("sheet2").Range("A3:G10000").ClearContents

nếu bạn muốn xóa như thế nào thì bạn tự điều chỉnh

Sub Loc()
    Dim Data As Variant, kQarr As Variant
    Dim lR As Long, k As Long, i As Long, w As Long
    Sheets("sheet2").Range("A3:G10000").ClearContents
    With Sheets("Sheet1")
        lR = .Range("A" & Rows.Count).End(3).Row
        Data = .Range("A3:E" & lR).Value
    End With
    If lR < 3 Then MsgBox "Sheet1 Không có so lieu": Exit Sub
    w = UBound(Data)
    ReDim kQarr(1 To w, 1 To 5)
    For i = 1 To UBound(Data)
        If Len(Data(i, 1)) Then
            k = k + 1
            kQarr(k, 1) = Data(i, 1)
            kQarr(k, 2) = Data(i, 3)
            kQarr(k, 3) = Data(i, 2)
            kQarr(k, 4) = Data(i, 5)
            kQarr(k, 5) = Data(i, 4)
        End If
    Next i
    Sheets("sheet2").[A3].Resize(k, 5) = kQarr
End Sub

 

[tuhumg00]

1/ Thêm bẫy lỗi trường hợp Sheet1: không có dữ liệu
2/ Code dưới sẽ xóa số liệu cũ từ

Sheets("sheet2").Range("A3:G10000").ClearContents

nếu bạn muốn xóa như thế nào thì bạn tự điều chỉnh

Sub Loc()
    Dim Data As Variant, kQarr As Variant
    Dim lR As Long, k As Long, i As Long, w As Long
    Sheets("sheet2").Range("A3:G10000").ClearContents
    With Sheets("Sheet1")
        lR = .Range("A" & Rows.Count).End(3).Row
        Data = .Range("A3:E" & lR).Value
    End With
    If lR < 3 Then MsgBox "Sheet1 Không có so lieu": Exit Sub
    w = UBound(Data)
    ReDim kQarr(1 To w, 1 To 5)
    For i = 1 To UBound(Data)
        If Len(Data(i, 1)) Then
            k = k + 1
            kQarr(k, 1) = Data(i, 1)
            kQarr(k, 2) = Data(i, 3)
            kQarr(k, 3) = Data(i, 2)
            kQarr(k, 4) = Data(i, 5)
            kQarr(k, 5) = Data(i, 4)
        End If
    Next i
    Sheets("sheet2").[A3].Resize(k, 5) = kQarr
End Sub

Trước tiên em cảm ơn bác đã giúp e. nhưng với code của bác giờ em muốn thêm cột vào dữ liệu ở sheet 1 thì ta lại phải chỉnh sửa
" kQarr(k, 1) = Data(i, 1)
kQarr(k, 2) = Data(i, 3)
kQarr(k, 3) = Data(i, 2)
kQarr(k, 4) = Data(i, 5)
kQarr(k, 5) = Data(i, 4)"
Phải không bác
Giờ em muốn thêm mấy cột, mặc định với trường hợp của e thì nó tương đối nhiều cột thì xử lý code thế nào bác nhỉ?.

 

[VetMini]

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...
...

Khi thì Sheet1-Sheet2, lúc lại 2 files khác nhau. Thế là thế nào?
Nói chuyện chả đồng nhất vậy không có code nào giải quyết được cả.

Giải thuật bài này là copy các cột cần thiết từ bên 1 sang bên 2. Sau đó chuyển vị trí cột (cut/insert).

 

[tuhumg00]

Khi thì Sheet1-Sheet2, lúc lại 2 files khác nhau. Thế là thế nào?
Nói chuyện chả đồng nhất vậy không có code nào giải quyết được cả.

Giải thuật bài này là copy các cột cần thiết từ bên 1 sang bên 2. Sau đó chuyển vị trí cột (cut/insert).

Bài toán e đang nhờ là ở 2 sheet khác nhau thôi mà, còn code thì mình sẽ tự chuyển đổi sang. chủ yếu cái thuật để copy sang sheets1 và sheet2 đã bác ạ.( của bác @AnhThu-1976 thì đang bị thiếu trường hợp là thêm dữ liệu cột thì chưa xử lý được. bác có cách nào chỉ em với.
-Trường hợp ở sheet1 nhiều lúc cột nó lộn xộn mà mình muốn cóp ô cần thiết thì khó làm theo kiểu bác đc. có thể có 100 cột chẳng hạn mà có những cột dữ liệu sheet1 thì mình không muốn cóp. mục đích bài toán của e là như vậy.

 

[AnhThu-1976]

Giải thuật bài này là copy các cột cần thiết từ bên 1 sang bên 2. Sau đó chuyển vị trí cột (cut/insert).

Chờ anh code cho giải thuật này

 

[befaint]

Khi thì Sheet1-Sheet2, lúc lại 2 files khác nhau. Thế là thế nào?
Nói chuyện chả đồng nhất vậy không có code nào giải quyết được cả.

Luôn tặng kèm khúc 'kể nể, khóc lóc' ý tưởng quẩn quanh, vòng vo trong đầu mà anh.
Không nói ra không chịu được.

---
Em thì quan tâm khúc này hơn:

Giờ em muốn thêm mấy cột, mặc định với trường hợp của e thì nó tương đối nhiều cột thì xử lý code thế nào

Củ cải bắt đầu được treo lên đầu cây sào rồi.

 

[Ba Tê]

Bài toán e đang nhờ là ở 2 sheet khác nhau thôi mà, còn code thì mình sẽ tự chuyển đổi sang. chủ yếu cái thuật để copy sang sheets1 và sheet2 đã bác ạ.

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...

 

[ilvba]

Những người này, vấn đề của họ không phải là kiến thức VBA, vấn đề là họ còn chẳng có nổi cái suy nghĩ logic thông thường. Nhìn vào thì thấy dễ, nhưng chẳng có cái gì cụ thể ở đây để code. Quả nhiên là code ngay lập tức bị phản hồi chưa đáp ứng.
Code chưa đáp ứng trong trường hợp này không phải do năng lực người code bị hạn chế, mà do diễn đạt logic của chủ topic vượt cả thời gian và không gian, cần người có chỉ số IQ rất cao mới có thể hiểu được.

 

[tuhumg00]

Luôn tặng kèm khúc 'kể nể, khóc lóc' ý tưởng quẩn quanh, vòng vo trong đầu mà anh.
Không nói ra không chịu được.

---
Em thì quan tâm khúc này hơn:

Củ cải bắt đầu được treo lên đầu cây sào rồi.

Trong hình vẽ ở dưới khác với hình vẽ ban đầu e hỏi, em có thêm dữ liệu sheet1 2 cột dữ liệu 5,6 giờ em muốn cóp sang sheet2 vào đúng cột dữ liệu sheet2. thế thôi mà bác, bác hiểu ý e ko?. không hiểu thì em chịu thoai.

 

[VetMini]

Những người này, vấn đề của họ không phải là kiến thức VBA, vấn đề là họ còn chẳng có nổi cái suy nghĩ logic thông thường. Nhìn vào thì thấy dễ, nhưng chẳng có cái gì cụ thể ở đây để code. Quả nhiên là code ngay lập tức bị phản hồi chưa đáp ứng.
Code chưa đáp ứng trong trường hợp này không phải do năng lực người code bị hạn chế, mà do diễn đạt logic của chủ topic vượt cả thời gian và không gian, cần người có chỉ số IQ rất cao mới có thể hiểu được.

Bạn có lẽ chưa quen với GPE nên mới nghĩ vậy.
Ở đây, nhiều người ghiền code và sửa code lắm. Chỉ cần một chút gợi ý ban đầu là sẽ có người đứng ra code. Sau đó hai bên mới từ từ chỉnh sửa cho đến lúc hội tụ ra cái code cuối cùng.
Mang tiếng là học hỏi nhưng cả bên yêu cầu, bên code, và khán giả chả ai học hỏi được gì ra hồn cả.
Bên yêu cầu thoả mãn yêu cầu. Bên code thoả mãn cái "ngứa". Bên khán giả thoả mãn cái "bình phẩm". Hết.

Nếu là học hỏi thì chính ra phải học cách nhìn vấn đề, phân tích, và ra giải thuật (*). Code chỉ là chuyện phụ, làm quen tay thôi.

(*) vấn đề lăn tăn nhỏ giọt thì giải thuật đương nhiên chỉ là một đống tạp nhạp, rác rưởi.

 

[ilvba]

Nếu là học hỏi thì chính ra phải học cách nhìn vấn đề, phân tích, và ra giải thuật (*). Code chỉ là chuyện phụ, làm quen tay thôi.

Cái vấn đề của topic này là cái gì đấy ạ. Nãy giờ em xem code cũng chưa thấy học hỏi được gì.
Cách nhìn vấn đề của bạn @AnhThu-1976 có vấn đề gì ạ? Nếu phải sửa thì sửa ở đâu ạ?

 

[tuhumg00]

Khi thì Sheet1-Sheet2, lúc lại 2 files khác nhau. Thế là thế nào?
Nói chuyện chả đồng nhất vậy không có code nào giải quyết được cả.

Giải thuật bài này là copy các cột cần thiết từ bên 1 sang bên 2. Sau đó chuyển vị trí cột (cut/insert).

Em trả lời bác vấn đề này:
Nếu bài toán e đặt ra mà cóp từ 2 book khác nhau copy từ book1 này sang book2 chẳng hạn thì cái thuật toán viết ra các bác lại viết dài hơn trường hợp của sheet1 và sheet2(e nói thế không biết có đúng không), cái vấn đề là các bác viết được với sheet ra rồi e sẽ sửa lại code cho trường hợp copy từ book1 này sang book2 mục đích bài toán của e là vậy( e vừa học hỏi được vấn đề vừa nâng cao kiến thức lên, vì e mới tập tọe nên ko biết nhiều về thuật toán. ví dụ làm thế nào để lấy dữ liệu trong cột 2a (sheet1) và điền dữ liệu vào cột 2a của sheet2(sheet chính), khi bác viết ra e sẽ tự suy luận và hiểu thì mới nhớ lâu.)

 

[HieuCD]

1/ Thêm bẫy lỗi trường hợp Sheet1: không có dữ liệu
2/ Code dưới sẽ xóa số liệu cũ từ

Sheets("sheet2").Range("A3:G10000").ClearContents

nếu bạn muốn xóa như thế nào thì bạn tự điều chỉnh

Sub Loc()
    Dim Data As Variant, kQarr As Variant
    Dim lR As Long, k As Long, i As Long, w As Long
    Sheets("sheet2").Range("A3:G10000").ClearContents
    With Sheets("Sheet1")
        lR = .Range("A" & Rows.Count).End(3).Row
        Data = .Range("A3:E" & lR).Value
    End With
    If lR < 3 Then MsgBox "Sheet1 Không có so lieu": Exit Sub
    w = UBound(Data)
    ReDim kQarr(1 To w, 1 To 5)
    For i = 1 To UBound(Data)
        If Len(Data(i, 1)) Then
            k = k + 1
            kQarr(k, 1) = Data(i, 1)
            kQarr(k, 2) = Data(i, 3)
            kQarr(k, 3) = Data(i, 2)
            kQarr(k, 4) = Data(i, 5)
            kQarr(k, 5) = Data(i, 4)
        End If
    Next i
    Sheets("sheet2").[A3].Resize(k, 5) = kQarr
End Sub

Dùng Dictionary để nhận diện thứ tự cột

 

[tuhumg00]

@Ba Tê Có thể e nói hơi tắt tí bác thông cảm. Trường hợp của e nhờ các bác code trong trường hợp copy sheet sang sang sheet khi bác code đc thì e sẽ tự sửa trường hợp book sang book( e sẽ tự phải mò mẫm làm để nâng cao kiến thức) chứ ăn sẵn luôn thì e ko muốn. Có những thuật toán tìm kiếm dữ liệu cọt 2a(sheet) để điền dữ liệu vào 2a(sheet2). Thì e chưa nghĩ ra đc.
- còn làm trong excell thì kết hợp mấy hàm là tìm đc dữ liệu nhưng khi làm với 2 file excell thì phải chọn range này range kia.... Và đường link tên file dài, (nếu để sâu trong forder) e ko muốn vậy Bác hiểu ý e ko ạ.

 

[VetMini]

... Có những thuật toán tìm kiếm dữ liệu cọt 2a(sheet) để điền dữ liệu vào 2a(sheet2). Thì e chưa nghĩ ra đc.
...

Cái này bà con cũng không nghĩ ra.
Theo như giải thích ở bài #1 thì lúc copy dữ liệu phải đúng dòng (ngụ ý của hàm Match). Nhưng cũng theo hình minh hoạ thì cứ việc copy cả cột và chèn vào. Hai kiểu này khác nhau.

Chú: giải thích bài thì tránh viết tắt. Nên nhớ rằng hầu hết các quy luật viết tắt giành cho giới cùng thời đại ngôn ngữ với nhau. Điển hình là thời của tôi từ kg có nghĩa là "kính gửi", ko có nghĩa là "knock out (giải quyết xong)", đc có nghĩa tục tỉu. Để có thể hiểu từ viết tắt của bạn, tôi phải đọc hai ba lượt để đưa nó vào đuungs ngữ cảnh. Nó không tự nhiên như bạn chủ quan vậy đâu.

 

[tuhumg00]

Sub loc()
Dim curr_row As Long, curr_col As Long, r As Long, c As Long, data(), result(), dic As Object, sh As Worksheet, wb As Workbook
    Set sh = ThisWorkbook.Worksheets("sheet2")
'    xet tap tin LOC
    With sh
'        xoa du lieu cu. Gia thiet la co nhieu nhat 100 000 Ma va 100 Cot
        .Range("B5").Resize(10000, 100).ClearContents
        curr_col = .Cells(4, Columns.Count).End(xlToLeft).Column
        If curr_col < 2 Then Exit Sub
        curr_row = .Cells(Rows.Count, "A").End(xlUp).Row
        If curr_row < 5 Then Exit Sub
        result = .Range(.Range("A4"), .Cells(curr_row, curr_col)).Value
    End With
    Set wb = ThisWorkbook
    With wb.Worksheets("sheet1")
        curr_col = .Cells(3, Columns.Count).End(xlToLeft).Column
        curr_row = .Cells(Rows.Count, "B").End(xlUp).Row
        If curr_col >= 3 And curr_row >= 4 Then data = .Range(.Range("B3"), .Cells(curr_row, curr_col)).Value
    End With
    If curr_col < 3 Or curr_row < 4 Then Exit Sub
    
    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 = 2 To UBound(data, 2)
        If Not dic.exists(data(1, c)) Then dic.Add data(1, c), c
    Next c
    For r = 2 To UBound(data)
        If Not dic.exists(data(r, 1)) Then dic.Add data(r, 1), r
    Next r
    For r = 2 To UBound(result)
        If dic.exists(result(r, 1)) Then
            curr_row = dic.Item(result(r, 1))
            For c = 2 To UBound(result, 2)
'                neu ton tai Cot hien hanh trong sheet1
                If dic.exists(result(1, c)) Then
                    curr_col = dic.Item(result(1, c))
                    result(r, c) = data(curr_row, curr_col)
                End If
            Next c
        End If
    Next r
    
    sh.Range("A4").Resize(UBound(result), UBound(result, 2)).Value = result
    Set dic = Nothing
End Sub

Nguồn code của bác @batman1
Qua một hồi tìm kiếm trên GPE và tìm thấy có một code của bác batman1 và e đã áp dụng , chỉnh sửa và phù hợp với trường hợp của em. như bác hiếu @HieuCD nói phải dùng dictionary để tìm dữ liệu và vị trí cột Dictionary đúng thật(vì cái này e chưa biết nên cũng ko biết code như thế nào chắc e còn phải đọc lại nhiều). e vẫn còn non kinh nhiệm nên còn phải học hỏi nhiều. về cách trình bày để các bác hiểu. Mong các bác thông cảm.
Xin trân thành cảm ơn các bác đã quan tâm đến vấn đề trợ giúp của em. xin học hỏi các bác bô lão nhiều. Chúc các bác một buổi tối vui vẻ.

 

[batman1]

Hôm nay bận giờ mới vào chủ đề này. Không ngờ mọi người tham dự vui vẻ quá.

Nguồn code của bác @batman1
Qua một hồi tìm kiếm trên GPE và tìm thấy có một code của bác batman1 và e đã áp dụng , chỉnh sửa và phù hợp với trường hợp của em. như bác hiếu @HieuCD nói phải dùng dictionary để tìm dữ liệu và vị trí cột Dictionary đúng thật(vì cái này e chưa biết nên cũng ko biết code như thế nào chắc e còn phải đọc lại nhiều).

Đúng rồi, dic trong code của tôi là dùng cho việc đó. Thực ra code không cao siêu. Cái quan trọng là ý tưởng.

 

[batman1]

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