Xin Code lấy dữ liệu có điều kiện từ sheet khác

[nguyenhongphuong0204]

Xin chào các anh/chị

Em có 2 sheets, 1 sheets data và 1 sheets report. Với điều kiện stick chọn ở các ô B3:B10 và F3:F6 sẽ chuyển sang vùng dữ liệu như sheets report. Em cũng loay hoay chiều giờ nhưng vì không biết code nên cũng mò mẫn các recording và các video nhưng kết quả không đúng và sai khi tự viết. Mong các anh/chị hỗ trợ giúp.

 

[Hoàng Trọng Nghĩa]

Xin chào các anh/chị

Em có 2 sheets, 1 sheets data và 1 sheets report. Với điều kiện stick chọn ở các ô B3:B10 và F3:F6 sẽ chuyển sang vùng dữ liệu như sheets report. Em cũng loay hoay chiều giờ nhưng vì không biết code nên cũng mò mẫn các recording và các video nhưng kết quả không đúng và sai khi tự viết. Mong các anh/chị hỗ trợ giúp.

Bạn thử dùng thủ tục sau:

Sub LietKe()
    Dim e As Long, m As Long, n As Long, r As Long, u As Long
    Dim arrTemp, arrTempCV, arrTempKV, arrCongViec(), arrKhuVuc()
    Dim shData As Worksheet, shReport As Worksheet
    Set shData = Sheets("data")
    Set shReport = Sheets("report")
    e = shData.Range("B" & Rows.Count).End(xlUp).Row
    arrTempCV = shData.Range("B3:C" & e).Value
    u = UBound(arrTempCV)
    For r = 1 To u
        If LCase(arrTempCV(r, 1)) = "x" Then
            m = m + 1
            ReDim Preserve arrCongViec(1 To m)
            arrCongViec(m) = arrTempCV(r, 2)
        End If
    Next
    
    e = shData.Range("F" & Rows.Count).End(xlUp).Row
    arrTempKV = shData.Range("F3:G" & e).Value
    u = UBound(arrTempKV)
    For r = 1 To u
        If LCase(arrTempKV(r, 1)) = "x" Then
            n = n + 1
            ReDim Preserve arrKhuVuc(1 To n)
            arrKhuVuc(n) = arrTempKV(r, 2)
        End If
    Next
    
    Dim arrResult
    Dim i As Long, j As Long
    u = n + n * m
    ReDim arrResult(1 To u, 1 To 4)
    For i = 1 To n
        j = j + 1
        arrResult(j, 1) = i
        arrResult(j, 3) = arrKhuVuc(i)
        For r = 1 To m
            j = j + 1
            arrResult(j, 2) = r
            arrResult(j, 4) = arrCongViec(r)
        Next
    Next
    shReport.Range("A2:D" & Rows.Count).Clear
    shReport.Range("A2:D2").Resize(u).Value = arrResult
End Sub

 

[be_09]

Xin chào các anh/chị

Em có 2 sheets, 1 sheets data và 1 sheets report. Với điều kiện stick chọn ở các ô B3:B10 và F3:F6 sẽ chuyển sang vùng dữ liệu như sheets report. Em cũng loay hoay chiều giờ nhưng vì không biết code nên cũng mò mẫn các recording và các video nhưng kết quả không đúng và sai khi tự viết. Mong các anh/chị hỗ trợ giúp.

Bạn thiết kế sai cấu trúc, nếu sửa cấu trúc lại thì code sẽ đơn giản và gọn hơn.

 

[Hoàng Trọng Nghĩa]

Bạn thiết kế sai cấu trúc, nếu sửa cấu trúc lại thì code sẽ đơn giản và gọn hơn.

Em thấy bình thường mà, ở bài #2 em làm kết quả ra như ý tác giả rồi, phần còn lại tác giả muốn định dạng thế nào thì tùy tác giả.

 

[BuiQuangThuan]

Thu 1 cach khac

Sub ABC()
Dim ws As Worksheet, Rng1 As Range, K&, K1&, X&
Dim WD As Worksheet: Set WD = Sheets("test")
Dim Rng As Range: Set ws = Sheets("data")
Application.ScreenUpdating = False
WD.Range("A2:D210000").ClearContents
dc = 1: X = 0
    For Each Rng In ws.Range("F3:F" & ws.Range("F" & Rows.Count).End(3).Row)
        If Rng.Value = "x" Then
            K = K + 1: X = X + 1
            WD.Range("A" & dc + X).Value = K
            WD.Range("A" & dc + X).Offset(, 2).Value = Rng.Offset(, 1).Value
            For Each Rng1 In ws.Range("B3:B" & ws.Range("B" & Rows.Count).End(3).Row)
                If Rng1.Value = "x" Then
                    K1 = K1 + 1: dc1 = dc1 + 1
                    WD.Range("B" & dc1 + X + 1).Value = K1
                    WD.Range("D" & dc1 + X + 1).Value = Rng1.Offset(, 1)
                End If
            Next
            dc = dc1 + 1
            K1 = 0
        End If
    Next
Application.ScreenUpdating = False
MsgBox "OK"
End Sub

 

[nguyenhongphuong0204]

Thu 1 cach khac

Sub ABC()
Dim ws As Worksheet, Rng1 As Range, K&, K1&, X&
Dim WD As Worksheet: Set WD = Sheets("test")
Dim Rng As Range: Set ws = Sheets("data")
Application.ScreenUpdating = False
WD.Range("A2:D210000").ClearContents
dc = 1: X = 0
    For Each Rng In ws.Range("F3:F" & ws.Range("F" & Rows.Count).End(3).Row)
        If Rng.Value = "x" Then
            K = K + 1: X = X + 1
            WD.Range("A" & dc + X).Value = K
            WD.Range("A" & dc + X).Offset(, 2).Value = Rng.Offset(, 1).Value
            For Each Rng1 In ws.Range("B3:B" & ws.Range("B" & Rows.Count).End(3).Row)
                If Rng1.Value = "x" Then
                    K1 = K1 + 1: dc1 = dc1 + 1
                    WD.Range("B" & dc1 + X + 1).Value = K1
                    WD.Range("D" & dc1 + X + 1).Value = Rng1.Offset(, 1)
                End If
            Next
            dc = dc1 + 1
            K1 = 0
        End If
    Next
Application.ScreenUpdating = False
MsgBox "OK"
End Sub

Bạn thử dùng thủ tục sau:

Sub LietKe()
    Dim e As Long, m As Long, n As Long, r As Long, u As Long
    Dim arrTemp, arrTempCV, arrTempKV, arrCongViec(), arrKhuVuc()
    Dim shData As Worksheet, shReport As Worksheet
    Set shData = Sheets("data")
    Set shReport = Sheets("report")
    e = shData.Range("B" & Rows.Count).End(xlUp).Row
    arrTempCV = shData.Range("B3:C" & e).Value
    u = UBound(arrTempCV)
    For r = 1 To u
        If LCase(arrTempCV(r, 1)) = "x" Then
            m = m + 1
            ReDim Preserve arrCongViec(1 To m)
            arrCongViec(m) = arrTempCV(r, 2)
        End If
    Next
  
    e = shData.Range("F" & Rows.Count).End(xlUp).Row
    arrTempKV = shData.Range("F3:G" & e).Value
    u = UBound(arrTempKV)
    For r = 1 To u
        If LCase(arrTempKV(r, 1)) = "x" Then
            n = n + 1
            ReDim Preserve arrKhuVuc(1 To n)
            arrKhuVuc(n) = arrTempKV(r, 2)
        End If
    Next
  
    Dim arrResult
    Dim i As Long, j As Long
    u = n + n * m
    ReDim arrResult(1 To u, 1 To 4)
    For i = 1 To n
        j = j + 1
        arrResult(j, 1) = i
        arrResult(j, 3) = arrKhuVuc(i)
        For r = 1 To m
            j = j + 1
            arrResult(j, 2) = r
            arrResult(j, 4) = arrCongViec(r)
        Next
    Next
    shReport.Range("A2:D" & Rows.Count).Clear
    shReport.Range("A2:D2").Resize(u).Value = arrResult
End Sub

Cám ơn sếp Nghĩa rất nhiều. Đúng là quá tuyệt.
Xin cám ơn anh Buiquangthuan

 

[Hoàng Trọng Nghĩa]

Thu 1 cach khac

Sub ABC()
Dim ws As Worksheet, Rng1 As Range, K&, K1&, X&
Dim WD As Worksheet: Set WD = Sheets("test")
Dim Rng As Range: Set ws = Sheets("data")
Application.ScreenUpdating = False
WD.Range("A2:D210000").ClearContents
dc = 1: X = 0
    For Each Rng In ws.Range("F3:F" & ws.Range("F" & Rows.Count).End(3).Row)
        If Rng.Value = "x" Then
            K = K + 1: X = X + 1
            WD.Range("A" & dc + X).Value = K
            WD.Range("A" & dc + X).Offset(, 2).Value = Rng.Offset(, 1).Value
            For Each Rng1 In ws.Range("B3:B" & ws.Range("B" & Rows.Count).End(3).Row)
                If Rng1.Value = "x" Then
                    K1 = K1 + 1: dc1 = dc1 + 1
                    WD.Range("B" & dc1 + X + 1).Value = K1
                    WD.Range("D" & dc1 + X + 1).Value = Rng1.Offset(, 1)
                End If
            Next
            dc = dc1 + 1
            K1 = 0
        End If
    Next
Application.ScreenUpdating = False
MsgBox "OK"
End Sub

Code này thì đúng thuật toán, nhưng nếu đem ra áp dụng tôi sẽ nghĩ nó xử lý chậm hơn bởi vì nó thực hiện trên Range còn thủ tục mình đưa lên nó chạy trên Array nên tốc độ sẽ nhanh hơn.

 

[BuiQuangThuan]

Code này thì đúng thuật toán, nhưng nếu đem ra áp dụng tôi sẽ nghĩ nó xử lý chậm hơn bởi vì nó thực hiện trên Range còn thủ tục mình đưa lên nó chạy trên Array nên tốc độ sẽ nhanh hơn.

Em cũng định viết trên mảng, Nhưng ngồi nghĩ lại. nếu dữ liệu thật của tác giả mà dài lê thê. chắc người ta sẽ thiết kế cấu trúc chuẩn ngay từ đầu. kiểu cấu trúc khác. Nói chung là em thấy code của anh rất hay. cám ơn vì anh đã chia sẻ.

 

[Hoàng Trọng Nghĩa]

Em cũng định viết trên mảng, Nhưng ngồi nghĩ lại. nếu dữ liệu thật của tác giả mà dài lê thê. chắc người ta sẽ thiết kế cấu trúc chuẩn ngay từ đầu. kiểu cấu trúc khác. Nói chung là em thấy code của anh rất hay. cám ơn vì anh đã chia sẻ.

Vậy thì bạn thử viết trên mảng đôi khi thuật toán của bạn lại nhanh hơn của tôi thì sao! Thử đi nào.

 

[be_09]

Em thấy bình thường mà, ở bài #2 em làm kết quả ra như ý tác giả rồi, phần còn lại tác giả muốn định dạng thế nào thì tùy tác giả.

1/ Anh chỉ nêu sheet data của chủ Topic thiết kế không phù hợp nên code nó mới lòng vòng, sửa cấu trúc lại một tí thì code sẽ ngắn gọn hơn.
2/ Anh không rõ ý đồ của chủ Topic nên không thiết kế lại và cũng không đưa ra giải pháp vì thấy không hợp lý, cụ thể sheet report, thấy nội dung cột D (Nhóm Công Việc) thì như nhau, chỉ khác chỗ khu vực A, B, C.
3/ Anh nghĩ. nếu sửa cấu trúc sheet data thì dùng UserForm với 1 ComboBox và 1 ListBox thì sẽ đáp ứng được công việc của chủ Topic.

 

[BuiQuangThuan]

Vậy thì bạn thử viết trên mảng đôi khi thuật toán của bạn lại nhanh hơn của tôi thì sao! Thử đi nào.

Nhờ anh chỉ giúp nếu còn thiếu sót ạ. Tại em cũng không biết nó nhanh hơn hay chậm hơn nữa. Có điều lúc đầu định làm trên mảng. xong lười. nên thôi. Hihi

Sub XYZ()
Dim arr(), i&, arr1(), K&, K1&, res(), DC&, DC1&, X&
arr = Sheets("data").Range("List.kv").Value
arr1 = Sheets("data").Range("List.cv").Value
ReDim res(1 To (UBound(arr, 1) * UBound(arr1, 1)) + UBound(arr, 1), 1 To 4)
DC = 1: X = -1
For i = 1 To UBound(arr, 1)
    If arr(i, 2) = "x" Then
        K = K + 1: X = X + 1
        res(DC + X, 1) = K
        res(DC + X, 3) = arr(i, 3)
        For j = 1 To UBound(arr1, 1)
            If arr1(j, 2) = "x" Then
                K1 = K1 + 1: DC1 = DC1 + 1
                res(DC1 + X + 1, 2) = K1
                res(DC1 + X + 1, 4) = arr1(j, 3)
            End If
        Next
        DC = DC1 + 1: K1 = 0
    End If
Next
With Sheets("Test")
    .Range("G2:J10000").ClearContents
    .Range("G2").Resize((UBound(arr, 1) * UBound(arr1, 1)) + (UBound(arr, 1)), 4).Value = res
End With
End Sub

 

[Hoàng Trọng Nghĩa]

1/ Anh chỉ nêu sheet data của chủ Topic thiết kế không phù hợp nên code nó mới lòng vòng, sửa cấu trúc lại một tí thì code sẽ ngắn gọn hơn.
2/ Anh không rõ ý đồ của chủ Topic nên không thiết kế lại và cũng không đưa ra giải pháp vì thấy không hợp lý, cụ thể sheet report, thấy nội dung cột D (Nhóm Công Việc) thì như nhau, chỉ khác chỗ khu vực A, B, C.
3/ Anh nghĩ. nếu sửa cấu trúc sheet data thì dùng UserForm với 1 ComboBox và 1 ListBox thì sẽ đáp ứng được công việc của chủ Topic.

Họ để chung trên một sheet là đúng rồi, VD có nhiều công việc và có nhiều khu vực. Nhưng hôm nay công việc tại các khu vực được đánh dấu x sẽ làm các công việc được đánh dấu x thì sẽ tổng hợp trên bản báo cáo liệt kê khu vực nào làm công việc gì. Chỉ vậy thôi, cấu trúc có gì đâu mà thắc mắc anh?

 

[HieuCD]

Nhờ anh chỉ giúp nếu còn thiếu sót ạ. Tại em cũng không biết nó nhanh hơn hay chậm hơn nữa. Có điều lúc đầu định làm trên mảng. xong lười. nên thôi. Hihi

Sub XYZ()
Dim arr(), i&, arr1(), K&, K1&, res(), DC&, DC1&, X&
arr = Sheets("data").Range("List.kv").Value
arr1 = Sheets("data").Range("List.cv").Value
ReDim res(1 To (UBound(arr, 1) * UBound(arr1, 1)) + UBound(arr, 1), 1 To 4)
DC = 1: X = -1
For i = 1 To UBound(arr, 1)
    If arr(i, 2) = "x" Then
        K = K + 1: X = X + 1
        res(DC + X, 1) = K
        res(DC + X, 3) = arr(i, 3)
        For j = 1 To UBound(arr1, 1)
            If arr1(j, 2) = "x" Then
                K1 = K1 + 1: DC1 = DC1 + 1
                res(DC1 + X + 1, 2) = K1
                res(DC1 + X + 1, 4) = arr1(j, 3)
            End If
        Next
        DC = DC1 + 1: K1 = 0
    End If
Next
With Sheets("Test")
    .Range("G2:J10000").ClearContents
    .Range("G2").Resize((UBound(arr, 1) * UBound(arr1, 1)) + (UBound(arr, 1)), 4).Value = res
End With
End Sub

Code bạn viết ngày càng hay, gởi bạn cách dùng các biến n, k, stt

Sub XYZ()
  Dim arr(), arr1(), res(), i&, r&, k&, n&, stt&
  arr = Sheets("data").Range("List.kv").Value
  arr1 = Sheets("data").Range("List.cv").Value
  ReDim res(1 To (UBound(arr, 1) * UBound(arr1, 1)) + UBound(arr, 1), 1 To 4)
  For i = 1 To UBound(arr, 1)
    If arr(i, 2) = "x" Then
      n = n + 1: k = k + 1: stt = 0
      res(k, 1) = n
      res(k, 3) = arr(i, 3)
      For r = 1 To UBound(arr1, 1)
        If arr1(r, 2) = "x" Then
          k = k + 1: stt = stt + 1
          res(k, 2) = stt
          res(k, 4) = arr1(r, 3)
        End If
      Next r
    End If
  Next i
  With Sheets("Test")
    .Range("G2:J10000").ClearContents
    .Range("G2").Resize(k, 4).Value = res
  End With
End Sub

 

[BuiQuangThuan]

@HieuCD cám ơn thầy đã giành lời khen ạ. Thật sự những gì em biết. Đều học từ thầy. Từ từng đoạn code của thầy giúp đỡ mọi người. Cố gắng đọc hiểu. Và tìm hiểu xem nó vận hành thế nào. Có lúc muốn hỏi. Nhưng sợ phiền tới thầy. Chắc sẽ còn phải học nhiều từ Thầy và mọi người ạ

 

[nguyenhongphuong0204]

1/ Anh chỉ nêu sheet data của chủ Topic thiết kế không phù hợp nên code nó mới lòng vòng, sửa cấu trúc lại một tí thì code sẽ ngắn gọn hơn.
2/ Anh không rõ ý đồ của chủ Topic nên không thiết kế lại và cũng không đưa ra giải pháp vì thấy không hợp lý, cụ thể sheet report, thấy nội dung cột D (Nhóm Công Việc) thì như nhau, chỉ khác chỗ khu vực A, B, C.
3/ Anh nghĩ. nếu sửa cấu trúc sheet data thì dùng UserForm với 1 ComboBox và 1 ListBox thì sẽ đáp ứng được công việc của chủ Topic.

Cám ơn chia sẻ của anh Be_09. File này em dùng để học và tìm hiểu về mảng Array và các thuật toán tạo vòng lặp cũng như xác định vị trí (nguồn đến) của dữ liệu được lọc ra.
Về nội dung #2 em xin chia sẻ như sau, các khu vực sẽ có tiểu khu vực và về cấu trúc thì giống như khu vực nhưng ở mức nhỏ hơn nhưng vẫn được cung cấp đầy đủ các công vụ như khu vực để tiện cho việc quản lý cấu trúc dữ liệu theo mô hình tháp ạ.

 

[be_09]

Cám ơn chia sẻ của anh Be_09. File này em dùng để học và tìm hiểu về mảng Array và các thuật toán tạo vòng lặp cũng như xác định vị trí (nguồn đến) của dữ liệu được lọc ra.
Về nội dung #2 em xin chia sẻ như sau, các khu vực sẽ có tiểu khu vực và về cấu trúc thì giống như khu vực nhưng ở mức nhỏ hơn nhưng vẫn được cung cấp đầy đủ các công vụ như khu vực để tiện cho việc quản lý cấu trúc dữ liệu theo mô hình tháp ạ.

1/ Quan điểm của tôi thì khác thiết kế tiêu đề cột của sheet Data làm sao đáp ứng tất cả mọi nhu cầu công việc có liên quan và tôi xem sheet này như một cái kho chứa, muốn làm việc gì đó thì vào kho lấy cái tương ứng ra theo quy định.
2/ Còn sheet report là lấy ra kết quả (cái này chỉ đáp ứng cho việc báo cáo theo mẫu), thực tế nếu chứa nhiều dòng dữ liệu thì việc tổng hợp sẽ rất khó khăn.