Nhờ viết code hợp dữ liệu từ các cột khác nhau trong các sheet khác nhau về 1 sheet. (1 người xem)

[minhtuan91]

Em chào anh chị.
Em nhờ anh chị viết code giúp em xử lý dữ liệu của file đính kèm.
Cụ thể file có 12 sheet trong số 1 sheet là để dò dữ liệu, 1 sheet là tổng hợp dữ liệu và 10 sheet là nguồn dữ liệu để đưa vào sheet tông hợp.
ở 10 sheet nguồn dữ liệu dữ liệu nằm ở các cột khác nhau không cố địng dòng và cột xuất hiện. Em nhờ anh chị giúp em CODE để đưa dữ liệu từ các sheét nguồn về SHEET TỔNG HỢP.
Nếu làm tay thì em sẽ copy dữ liệu từ các sheet dữ liệu vào 1 cột sau đó Remove duplicates để lấy tên xuất hiện duy nhất rồi copy vào ô A4 ở sheet Tổng hợp.
Em cảm ơn anh chị

 

[HieuCD]

Em chào anh chị.
Em nhờ anh chị viết code giúp em xử lý dữ liệu của file đính kèm.
Cụ thể file có 12 sheet trong số 1 sheet là để dò dữ liệu, 1 sheet là tổng hợp dữ liệu và 10 sheet là nguồn dữ liệu để đưa vào sheet tông hợp.
ở 10 sheet nguồn dữ liệu dữ liệu nằm ở các cột khác nhau không cố địng dòng và cột xuất hiện. Em nhờ anh chị giúp em CODE để đưa dữ liệu từ các sheét nguồn về SHEET TỔNG HỢP.
Nếu làm tay thì em sẽ copy dữ liệu từ các sheet dữ liệu vào 1 cột sau đó Remove duplicates để lấy tên xuất hiện duy nhất rồi copy vào ô A4 ở sheet Tổng hợp.
Em cảm ơn anh chị

bạn chạy code sau

Sub DanhMucMa()
Dim Darr(), Arr(1 To 65000, 1 To 1), Dic As Object, shName As String, Rng As Range, i As Long, n As Long, k As Byte
Set Dic = CreateObject("Scripting.Dictionary")
Sheets(12).Activate
shName = ActiveSheet.Name
For k = 1 To Sheets.Count
    If Sheets(k).Name <> shName Then
        For Each Rng In Sheets(k).UsedRange
            If LCase(Left(Trim(Rng.Value), 2)) = "m" & ChrW(227) Then
                If Rng.Offset(60000).End(xlUp).Row > Rng.Row Then
                    Darr = Sheets(k).Range(Rng.Offset(1), Rng.Offset(60000).End(xlUp)).Value
                    For i = 1 To UBound(Darr)
                        If Darr(i, 1) <> "" And Not Dic.exists(Darr(i, 1)) Then
                            Dic.Add Darr(i, 1), ""
                            n = n + 1: Arr(n, 1) = Darr(i, 1)
                        End If
                    Next i
                End If
            End If
        Next Rng
    End If
Next k
Set Dic = Nothing
Range("A4").Resize(n) = Arr
End Sub

 

[minhtuan91]

@ anh HieuCD. Em cảm ơn anh. Em chạy code đã ok. Theo em hiểu thì đoạn code trên sẽ cắt bên trái 2 kí tự và nếu = " mã " thì xét cột đó để hiện yêu cầu. Em muốn code cắt bên phải 4 kí tự = " bccs " thì xét cột đó để thực hiện yêu cầu. Em đã sửa code của anh lại như sau:
If LCase(Left(Trim(Rng.Value), 2)) = "m" & ChrW(227) Then sửa thành If LCase(right(Trim(Rng.Value), 4)) = "bccs"
Nhưng code không chạy. Anh giúp em sửa code nhé. ^^