Dò tìm và thống kê sang dòng

Vũ Tuấn Tùng · 15/1/22

Em chào toàn thể anh chị em trên diễn đàn GPE!
Em có file Theo dõi công việc là cần dò tìm xã/phường ( có 14 xã/phường) tại ô ("F1") của sheet1 và chuyển sang dữ liệu dòng ở sheet2
đây là bảng dữ liệu phân công lịch của em cần dò tìm theo điều kiện ở ô ("F1")

em ví dụ kết quả mong muốn như ảnh dưới đây:
em minh hoạ xã Nam Mẫu được vài dòng ạ,

em minh hoạ xã Cao Thượng cũng được vài dòng ạ,

Rất mong mọi người giúp em đoạn code để thao tác nhanh hơn ạ, chứ là thủ công mất thời gian quá ạ
Em xin chân thành cảm ơn mọi người ạ.

HieuCD · 15/1/22

vutungbkvn đã viết:
Em chào toàn thể anh chị em trên diễn đàn GPE!
Em có file Theo dõi công việc là cần dò tìm xã/phường ( có 14 xã/phường) tại ô ("F1") của sheet1 và chuyển sang dữ liệu dòng ở sheet2
đây là bảng dữ liệu phân công lịch của em cần dò tìm theo điều kiện ở ô ("F1")
View attachment 271450
em ví dụ kết quả mong muốn như ảnh dưới đây:
em minh hoạ xã Nam Mẫu được vài dòng ạ,
View attachment 271451
em minh hoạ xã Cao Thượng cũng được vài dòng ạ,
View attachment 271452
Rất mong mọi người giúp em đoạn code để thao tác nhanh hơn ạ, chứ là thủ công mất thời gian quá ạ
Em xin chân thành cảm ơn mọi người ạ.

Tên sheet không nên dùng tiếng Việt có dấu
Thay đổi giá trị ô F1 trong sheet Phân công lịch code sẽ tự chạy
Code trong sheet Phân công lịch

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow&, n&
  If Target.Address = "$F$1" Then
    eRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 2 Then Sheet2.Range("A3:U" & eRow).Clear
    
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 3 Then
      If Target.Value <> Empty Then
        Call CapNhat(Range("A2:D" & eRow).Value, Target.Value)
      End If
    End If
  End If
End Sub

Code trong Module 1

Mã:

Option Explicit
Option Compare Text
Sub CapNhat(ByVal sArr, ByVal xa$)
  Dim aNV(), res(), dic As Object
  Dim sRow&, sCol&, i&, r&, k&, j&
 
  Set dic = CreateObject("scripting.dictionary")
  dic.CompareMode = 1
  aNV = Sheet2.Range("A2:U2").Value
  sCol = UBound(aNV, 2)
  For j = 4 To sCol
    dic.Item(aNV(1, j)) = j
  Next j
  sRow = UBound(sArr)
  ReDim res(1 To Int(sRow / 20) + 1, 1 To sCol)
  For i = 1 To sRow Step 20
    For j = 2 To 4
      If sArr(i, j) = xa Then
        k = k + 1
        res(k, 1) = sArr(i + 1, 1)
        res(k, 2) = sArr(i, 1)
        res(k, 3) = xa
        For r = i + 2 To i + 19
          If r <= sRow Then
            If dic.exists(sArr(r, 1)) Then
              res(k, dic.Item(sArr(r, 1))) = sArr(r, j)
            End If
          End If
        Next r
      End If
    Next j
  Next i
  If k Then
    Sheet2.Range("A3").Resize(k, sCol).NumberFormat = "@"
    Sheet2.Range("A3").Resize(k, sCol).Borders.LineStyle = 1
    Sheet2.Range("A3").Resize(k, sCol) = res
  End If
End Sub

Vũ Tuấn Tùng · 15/1/22

HieuCD đã viết:

Tên sheet không nên dùng tiếng Việt có dấu
Thay đổi giá trị ô F1 trong sheet Phân công lịch code sẽ tự chạy
Code trong sheet Phân công lịch

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow&, n&
  If Target.Address = "$F$1" Then
    eRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 2 Then Sheet2.Range("A3:U" & eRow).Clear
   
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 3 Then
      If Target.Value <> Empty Then
        Call CapNhat(Range("A2:D" & eRow).Value, Target.Value)
      End If
    End If
  End If
End Sub

Code trong Module 1

Mã:

Option Explicit
Option Compare Text
Sub CapNhat(ByVal sArr, ByVal xa$)
  Dim aNV(), res(), dic As Object
  Dim sRow&, sCol&, i&, r&, k&, j&
 
  Set dic = CreateObject("scripting.dictionary")
  dic.CompareMode = 1
  aNV = Sheet2.Range("A2:U2").Value
  sCol = UBound(aNV, 2)
  For j = 4 To sCol
    dic.Item(aNV(1, j)) = j
  Next j
  sRow = UBound(sArr)
  ReDim res(1 To Int(sRow / 20) + 1, 1 To sCol)
  For i = 1 To sRow Step 20
    For j = 2 To 4
      If sArr(i, j) = xa Then
        k = k + 1
        res(k, 1) = sArr(i + 1, 1)
        res(k, 2) = sArr(i, 1)
        res(k, 3) = xa
        For r = i + 2 To i + 19
          If r <= sRow Then
            If dic.exists(sArr(r, 1)) Then
              res(k, dic.Item(sArr(r, 1))) = sArr(r, j)
            End If
          End If
        Next r
      End If
    Next j
  Next i
  If k Then
    Sheet2.Range("A3").Resize(k, sCol).NumberFormat = "@"
    Sheet2.Range("A3").Resize(k, sCol).Borders.LineStyle = 1
    Sheet2.Range("A3").Resize(k, sCol) = res
  End If
End Sub

Em cảm ơn anh nhiều vì đã góp ý và giúp em đoạn code.
Anh có thể sửa giúp em lỗi nếu trùng tên ở cột A của sheet1 thì sang sheet2 chỉ nhận của 1 tên thôi ạ

HieuCD · 15/1/22

vutungbkvn đã viết:
Em cảm ơn anh nhiều vì đã góp ý và giúp em đoạn code.
Anh có thể sửa giúp em lỗi nếu trùng tên ở cột A của sheet1 thì sang sheet2 chỉ nhận của 1 tên thôi ạ

Bạn muốn kết quả như thế nào? gởi file với dữ liệu thực và kết quả minh họa

Vũ Tuấn Tùng · 15/1/22

HieuCD đã viết:
Bạn muốn kết quả như thế nào? gởi file với dữ liệu thực và kết quả minh họa

Ví dụ như là dòng của Nhất, Cân, Phúc trong sheet1 khi chuyển sang sheet2 thì sẽ tương ứng với dòng đó ạ

HieuCD · 15/1/22

vutungbkvn đã viết:
Ví dụ như là dòng của Nhất, Cân, Phúc trong sheet1 khi chuyển sang sheet2 thì sẽ tương ứng với dòng đó ạ

Những tên trùng là 1 người hay nhiều người?

Vũ Tuấn Tùng · 15/1/22

HieuCD đã viết:
Những tên trùng là 1 người hay nhiều người?

Dạ, tên trùng là 1 người ạ,

HieuCD · 15/1/22

vutungbkvn đã viết:
Dạ, tên trùng là 1 người ạ,

Tại sao sheet theo dõi 1 người có nhiều cột vậy, những ngày khác có nhân viên khác nhau thì kết quả như thế nào?

Vũ Tuấn Tùng · 15/1/22

HieuCD đã viết:
Tại sao sheet theo dõi 1 người có nhiều cột vậy, những ngày khác có nhân viên khác nhau thì kết quả như thế nào?

Em xin lỗi vì lỗi diễn tả trình bày của em hơi kém, em có sửa lại nội dung để dễ hiểu hơn ạ.
em ví dụ bằng con số cho đỡ rối mắt:

và kết quả em mong muốn là các dòng trùng nhau sẽ lấy dữ liệu từ dưới lên và chuyển sang sheets"Theo Doi" là từ trái sang phải như này ạ:

Mong anh giúp em với ạ.

HieuCD · 15/1/22

vutungbkvn đã viết:
Em xin lỗi vì lỗi diễn tả trình bày của em hơi kém, em có sửa lại nội dung để dễ hiểu hơn ạ.
em ví dụ bằng con số cho đỡ rối mắt:

và kết quả em mong muốn là các dòng trùng nhau sẽ lấy dữ liệu từ dưới lên và chuyển sang sheets"Theo Doi" là từ trái sang phải như này ạ:

Mong anh giúp em với ạ.

File mới đâu giống file trước, dữ liệu khác code phải khác. Gởi file thật lên mới viết code được

Vũ Tuấn Tùng · 15/1/22

HieuCD đã viết:
File mới đâu giống file trước, dữ liệu khác code phải khác. Gởi file thật lên mới viết code được

Hình thức giống file cũ ạ, chẳng qua là em thay đổi "Tổ" bằng số để dễ nhìn thôi ạ, còn code của anh chạy vẫn bình thường nếu cột A của sheets"Phan Cong Lich" không bị trùng ạ

Hoàng Tuấn 868 · 15/1/22

HieuCD đã viết:
File mới đâu giống file trước, dữ liệu khác code phải khác. Gởi file thật lên mới viết code được

Mỗi file mỗi kiểu, anh viết sao cho xuể đây.

Vũ Tuấn Tùng · 15/1/22

Hoàng Tuấn 868 đã viết:
Mỗi file mỗi kiểu, anh viết sao cho xuể đâ

Em xin lỗi, lúc đầu em không nghĩ đến trường hợp bị lặp lại ở cột A trong sheets1 ạ, em sửa nội dung để cho dễ trình bày thôi ạ, vì em kém về cách trình bày để mọi người hiểu ạ

Hoàng Tuấn 868 · 15/1/22

vutungbkvn đã viết:
em sửa

Vậy mỗi lấn sửa là một lần viết lại code thôi bạn.

vutungbkvn đã viết:
vì em kém về cách trình bày

Nếu kém trình bày thì đưa file nguyên dạng lên chứ.

Vũ Tuấn Tùng · 15/1/22

Hoàng Tuấn 868 đã viết:
Vậy mỗi lấn sửa là một lần viết lại code thôi bạn.

Nếu kém trình bày thì đưa file nguyên dạng lên chứ.

ý tưởng của em là vậy, em đang tổng hợp bảng công việc của tổ đội để báo cáo

HieuCD · 15/1/22

vutungbkvn đã viết:
Hình thức giống file cũ ạ, chẳng qua là em thay đổi "Tổ" bằng số để dễ nhìn thôi ạ, còn code của anh chạy vẫn bình thường nếu cột A của sheets"Phan Cong Lich" không bị trùng ạ

Code theo file mới, file khác tự lo

Mã:

Option Explicit
Option Compare Text
Sub CapNhat(ByVal sArr, ByVal xa$)
  Dim res(), dic As Object
  Dim sRow&, sCol&, i&, r&, k&, j&, c&

  sRow = UBound(sArr)
  sCol = Sheet2.Range("A2:U2").Columns.Count
  ReDim res(1 To Int(sRow / 20) + 1, 1 To 21)
  For i = 1 To sRow Step 20
    For j = 2 To 4
      If sArr(i, j) = xa Then
        k = k + 1
        res(k, 1) = sArr(i + 1, 1)
        res(k, 2) = sArr(i, 1)
        res(k, 3) = xa
        c = sCol
        For r = i + 2 To i + 19
          If r <= sRow Then
            res(k, c) = sArr(r, j)
          End If
          c = c - 1
        Next r
      End If
    Next j
  Next i
  If k Then
    Sheet2.Range("A3").Resize(k, sCol).NumberFormat = "@"
    Sheet2.Range("A3").Resize(k, sCol).Borders.LineStyle = 1
    Sheet2.Range("A3").Resize(k, sCol) = res
  End If
End Sub

Vũ Tuấn Tùng · 15/1/22

HieuCD đã viết:

Code theo file mới, file khác tự lo

Mã:

Option Explicit
Option Compare Text
Sub CapNhat(ByVal sArr, ByVal xa$)
  Dim res(), dic As Object
  Dim sRow&, sCol&, i&, r&, k&, j&, c&

  sRow = UBound(sArr)
  sCol = Sheet2.Range("A2:U2").Columns.Count
  ReDim res(1 To Int(sRow / 20) + 1, 1 To 21)
  For i = 1 To sRow Step 20
    For j = 2 To 4
      If sArr(i, j) = xa Then
        k = k + 1
        res(k, 1) = sArr(i + 1, 1)
        res(k, 2) = sArr(i, 1)
        res(k, 3) = xa
        c = sCol
        For r = i + 2 To i + 19
          If r <= sRow Then
            res(k, c) = sArr(r, j)
          End If
          c = c - 1
        Next r
      End If
    Next j
  Next i
  If k Then
    Sheet2.Range("A3").Resize(k, sCol).NumberFormat = "@"
    Sheet2.Range("A3").Resize(k, sCol).Borders.LineStyle = 1
    Sheet2.Range("A3").Resize(k, sCol) = res
  End If
End Sub

vâng em cảm ơn anh nhiều ạ, chúc anh mạnh khoẻ ạ.

Dò tìm và thống kê sang dòng

Thành viên mới

File đính kèm

Chuyên gia GPE

File đính kèm

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

Thành viên mới

File đính kèm

Chuyên gia GPE

Thành viên mới

Đăng ký hôm qua

Thành viên mới

Đăng ký hôm qua

Thành viên mới

Chuyên gia GPE

File đính kèm

Thành viên mới