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

Liên hệ QC

Vũ Tuấn Tùng

Thành viên mới
Tham gia
22/6/16
Bài viết
15
Được thích
0
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")
123.JPG
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 ạ,
1234.JPG
em minh hoạ xã Cao Thượng cũng được vài dòng ạ,
12345.JPG
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 ạ.
 

File đính kèm

  • TheoDoi_CongViec.xlsb
    41 KB · Đọc: 3

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,672
Được thích
18,527
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
 

File đính kèm

  • TheoDoi_CongViec.xlsb
    51.8 KB · Đọc: 9
Upvote 0

Vũ Tuấn Tùng

Thành viên mới
Tham gia
22/6/16
Bài viết
15
Được thích
0
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 ạ

321.JPG







431.JPG
 
Upvote 0

Vũ Tuấn Tùng

Thành viên mới
Tham gia
22/6/16
Bài viết
15
Được thích
0
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:

123.JPG
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 ạ:

1234.JPG
Mong anh giúp em với ạ.
 

File đính kèm

  • TheoDoi_CongViec_DaSua.xlsb
    29.4 KB · Đọc: 2
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,672
Được thích
18,527
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
 
Upvote 0

Vũ Tuấn Tùng

Thành viên mới
Tham gia
22/6/16
Bài viết
15
Được thích
0
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 ạ
 
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,672
Được thích
18,527
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
 

File đính kèm

  • TheoDoi_CongViec_DaSua.xlsb
    30.9 KB · Đọc: 7
Upvote 0

Vũ Tuấn Tùng

Thành viên mới
Tham gia
22/6/16
Bài viết
15
Được thích
0
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ẻ ạ.
 
Upvote 0
Web KT
Top Bottom