Giúp code tổng hợp (1 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

tueyennhi

Thành viên tích cực
Tham gia
18/10/10
Bài viết
1,192
Được thích
105
Chào anh chị.

Em có file dữ liệu với nhiều sheet khác nhau, có cách nào chạy file lọc lấy giá trị cột ID của tất cả các sheet kia vào sheet tổng hợp không ạ? Với điều kiện ID trong sheet tổng hợp là duy nhất (chỉ lấy ID khác biệt vào file tổng hợp, không lặp lại các ID đã có.

Em cảm ơn.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Nhờ code này của anh Lê Duy Thương

Sub add_acount()
Dim Dic, ws As Worksheet, iRow As Long, i As Long, Arr(), TmpArr, Tmp
On Error Resume Next
Application.ScreenUpdating = False
Sheet1.Range("a3:f5000").ClearContents
Set Dic = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
If ws.Name <> Sheet1 Then
TmpArr = ws.Range(ws.[a2], ws.[a5000].End(xlUp)).Value
For iRow = 1 To UBound(TmpArr, 1)
Tmp = TmpArr(iRow, 1)
If Not IsEmpty(Tmp) Then
If Not Dic.Exists(Tmp) Then
Dic.Add Tmp, ""
i = i + 1
ReDim Preserve Arr(1 To 1, 1 To i)
Arr(1, i) = TmpArr(iRow, 1)
'.................................
End If
End If
Next
End If
Next
With Sheet1
.Range("a3").Resize(i, 1) = WorksheetFunction.Transpose(Arr)
.Range("B3").FormulaR1C1 = _
"=SUMIF(INDIRECT(--RIGHT(R2C,2)&""!$A1:$A5000""),RC1,INDIRECT(--RIGHT(R2C,2)&""!$b1:$b5000""))"
.Range("B3").AutoFill Destination:=Range("B3:F3"), Type:=xlFillDefault
.Range("B3:F3").AutoFill Destination:=Range("B3:f" & [a5000].End(xlUp).Row)
.Range("B3:f" & [a5000].End(xlUp).Row).Value = Range("B3:f" & [a5000].End(xlUp).Row).Value

End With
Application.ScreenUpdating = True
End Sub

Em đã áp dụng vào file của mình được rồi. Cảm ơn anh nhiều!
 
Upvote 0
Chào anh Befaint, anh xem lại file của em xem nhé, Code của anh Lê Duy Thương em chưa áp dụng được triệt để, mới chỉ dừng ở mức lấy ID từ các sheet sao cho sheet tổng hợp ID đó là duy nhất, còn lại để áp giờ công của từng ngày vào sheet tổng hợp thì em chưa làm được. Ở mức vba cao như thế này em không có cơ bản nên em không hiểu code của anh cũng như của anh Thương. Dễ chút em còn có thể mò được chứ phức tạp như vậy khó quá, mong anh chỉ giúp em ạ.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
Chào anh Befaint, anh xem lại file của em xem nhé, Code của anh Lê Duy Thương em chưa áp dụng được triệt để, mới chỉ dừng ở mức lấy ID từ các sheet sao cho sheet tổng hợp ID đó là duy nhất, còn lại để áp giờ công của từng ngày vào sheet tổng hợp thì em chưa làm được. Ở mức vba cao như thế này em không có cơ bản nên em không hiểu code của anh cũng như của anh Thương. Dễ chút em còn có thể mò được chứ phức tạp như vậy khó quá, mong anh chỉ giúp em ạ.
Nhấp chuột vào đây để mở rộng...
Bạn nói vậy làm tôi tự thấy xí hổ...:=\+
Cái đó là của anh ndu96081631
PHP: 
Function UniqueArray(SrcRng As Range) 'ndu96081631 -GPE
  Dim Src, tmp As String, arr()
  Dim i As Long, j As Long, n As Long
  Src = SrcRng.Value
  ReDim arr(1 To UBound(Src, 1), 1 To UBound(Src, 2))
  With CreateObject("Scripting.Dictionary")
    For i = LBound(Src, 1) To UBound(Src, 1)
      tmp = ""
      For j = LBound(Src, 2) To UBound(Src, 2)
        tmp = tmp & Src(i, j)
      Next
      If tmp <> "" Then
        If Not .Exists(tmp) Then
          n = n + 1
          .Add tmp, ""
          For j = LBound(Src, 2) To UBound(Src, 2)
            arr(n, j) = Src(i, j)
          Next
        End If
      End If
    Next
  End With
  If j <> 0 Then
    UniqueArray = arr
  End If
End Function
Tôi chỉ làm động tác copy dữ liệu từ các sheets vào sheet "Tong hop".
PHP: 
Sub TongHop()
Dim lr As Long, rw As Long, i As Long, tmp
Sheet1.Range("A4:C65000").ClearContents
For i = 2 To Worksheets.Count
    lr = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
    rw = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
    tmp = Sheets(i).Range("A3:C" & lr).Value
    Sheets(1).Cells(rw + 1, 1).Resize(UBound(tmp), 3) = tmp
Next
rw = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
tmp = UniqueArray(Sheets(1).Range("A4:C" & rw))
Sheets(1).Range("A4").Resize(UBound(tmp), 3) = tmp
End Sub
p/s: Nếu tổng ID ở các sheets > số dòng của bảng tính thì phải chạy UniqueArray trước khi gán xuống sheet "Tong hop".
Chúc bạn một ngày vui!
 
Lần chỉnh sửa cuối:
Upvote 0
Anh ơi code này nó gộp tất cả giờ vào một cột thôi. Em muốn giờ công của ngày nào sẽ vào cột của ngày tương ứng. Anh xem lại cho em nhé. Em có thấy trong code trích dẫn của thầy ndu, nhưng để viết được thêm đoạn của anh đối với em là cả hành trình rất dài rồi anh ạ :(
 
Upvote 0
Vâng anh xem lại giúp em, cái này chắc phức tạp hơn nhiều !$@!!
 
Upvote 0
Anh ơi code này nó . . .
Nhấp chuột vào đây để mở rộng...
Bạn xài macro thô sơ này thử:
PHP: 
Option Explicit
Sub THCC()
Dim Dic1 As Object, Arr() As Variant, TmpArr As Variant, Sh As Worksheet
Dim Rws As Long, J As Long, W As Long, Col As Byte
Dim SN As String
With Sheets("Tong Hop")
  .Range("b4").CurrentRegion.Offset(1).ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
  ReDim Arr(1 To 9999, 1 To 9)
  For Each Sh In ThisWorkbook.Worksheets
    SN = Sh.Name
    If IsNumeric(SN) Then
        For J = 3 To Sh.[a3].End(xlDown).Row
            If Sh.Cells(J, "A").Value = "" Then Exit For
            Col = CByte(SN) * 2
            If Not Dic1.exists(Sh.Cells(J, "A").Value) Then
                W = W + 1
                Arr(W, 1) = Sh.Cells(J, "A").Value
                Dic1.Add Sh.Cells(J, "A").Value, W
                Arr(W, Col) = Sh.Cells(J, "B").Value
                Arr(W, 1 + Col) = Sh.Cells(J, "C").Value
            Else
                Arr(Dic1.Item(Sh.Cells(J, "A").Value), Col) = Sh.Cells(J, "B").Value
                Arr(Dic1.Item(Sh.Cells(J, "A").Value), 1 + Col) = Sh.Cells(J, "C").Value
            End If
        Next J
    End If
  Next Sh
  If W Then
    .[A4].Resize(W, 9).Value = Arr()
  End If
 End With
End Sub
Nếu nhiều người trong CQ sẽ fải tìm cách tăng tốc sau!
 
Upvote 0
HYen17 đã viết:
Bạn xài macro thô sơ này thử:
PHP: 
Option Explicit
Sub THCC()
Dim Dic1 As Object, Arr() As Variant, TmpArr As Variant, Sh As Worksheet
Dim Rws As Long, J As Long, W As Long, Col As Byte
Dim SN As String
With Sheets("Tong Hop")
  .Range("b4").CurrentRegion.Offset(1).ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
  ReDim Arr(1 To 9999, 1 To 9)
  For Each Sh In ThisWorkbook.Worksheets
    SN = Sh.Name
    If IsNumeric(SN) Then
        For J = 3 To Sh.[a3].End(xlDown).Row
            If Sh.Cells(J, "A").Value = "" Then Exit For
            Col = CByte(SN) * 2
            If Not Dic1.exists(Sh.Cells(J, "A").Value) Then
                W = W + 1
                Arr(W, 1) = Sh.Cells(J, "A").Value
                Dic1.Add Sh.Cells(J, "A").Value, W
                Arr(W, Col) = Sh.Cells(J, "B").Value
                Arr(W, 1 + Col) = Sh.Cells(J, "C").Value
            Else
                Arr(Dic1.Item(Sh.Cells(J, "A").Value), Col) = Sh.Cells(J, "B").Value
                Arr(Dic1.Item(Sh.Cells(J, "A").Value), 1 + Col) = Sh.Cells(J, "C").Value
            End If
        Next J
    End If
  Next Sh
  If W Then
    .[A4].Resize(W, 9).Value = Arr()
  End If
 End With
End Sub
Nếu nhiều người trong CQ sẽ fải tìm cách tăng tốc sau!
Nhấp chuột vào đây để mở rộng...

Chào anh, file của em chỉ là file mẫu thôi, thực tế em làm bảng chấm công tổng hợp trong một tháng, mỗi sheet là một ngày công. Ý định của em là qua form mẫu để áp dụng vào form thực tế, nhưng thú thực mọi người em không hiểu để có thể áp dụng vào file thực tế, vì vậy em up lại file em đang phải làm anh xem lại giúp em nhé.
Em chỉ cho 2 sheet ngày công ví dụ, thực tế thì chu kỳ lương sẽ là từ 26 tháng trước đến 25 tháng này (mỗi ngày là một sheet).
 

File đính kèm

Upvote 0
Tạm như vầy, sai ráng sửa --=0
Sub:
PHP: 
Sub TongHop()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim lr As Long, rw As Long, i As Long, cl As Long
Dim tmp, ID
Sheet1.Range("A4:ZZ65000").ClearContents
For i = 2 To Worksheets.Count
    lr = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
    rw = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
    tmp = Sheets(i).Range("A3:A" & lr).Value
    Sheets(1).Cells(rw + 1, 1).Resize(UBound(tmp)) = tmp
Next
rw = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
tmp = UniqueArray(Sheets(1).Range("A4:A" & rw))
Sheets(1).Range("A4").Resize(UBound(tmp)) = tmp
rw = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To Worksheets.Count
    lr = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
    tmp = Sheets(i).Range("A3:C" & lr).Value
    On Error Resume Next
    For j = 1 To UBound(tmp)
        ID = WorksheetFunction.Match(tmp(j, 1), Sheets(1).Range("A1:A" & rw), 0)
        cl = Sheet1.Cells(ID, Columns.Count).End(xlToLeft).Column
        Sheet1.Cells(ID, cl + 1) = tmp(j, 2)
        Sheet1.Cells(ID, cl + 2) = tmp(j, 3)
    Next j
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function UniqueArray thì bạn chép lại như bài trước.
 
Upvote 0
Bạn kiểm số liệu theo file; . . . Có gì thì chỉnh tiếp
 

File đính kèm

Upvote 0
ChanhTQ@ đã viết:
Bạn kiểm số liệu theo file; . . . Có gì thì chỉnh tiếp
Nhấp chuột vào đây để mở rộng...
File này mình phải lọc dữ liệu ID trước sau đó copy vào sheet bcc đúng không anh? Em xóa hết dữ liệu trong bcc chạy thử thì đơ luôn anh ạ. Còn lại nếu có ID rồi thì file này quả thật là quá tuyệt, chạy nhanh quá sức tưởng tượng anh ạ }}}}}

Untitled.jpg
 
Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
Chào anh Befaint, anh xem lại file của em xem nhé, Code của anh Lê Duy Thương em chưa áp dụng được triệt để, mới chỉ dừng ở mức lấy ID từ các sheet sao cho sheet tổng hợp ID đó là duy nhất, còn lại để áp giờ công của từng ngày vào sheet tổng hợp thì em chưa làm được. Ở mức vba cao như thế này em không có cơ bản nên em không hiểu code của anh cũng như của anh Thương. Dễ chút em còn có thể mò được chứ phức tạp như vậy khó quá, mong anh chỉ giúp em ạ.
Nhấp chuột vào đây để mở rộng...
bạn đã hỏi và được trả lời ở đây
http://www.giaiphapexcel.com/forum/...nhiều-sheet-vào-một-sheet&p=745478#post745478
 
Upvote 0
ChanhTQ@ đã viết:
Bạn kiểm số liệu theo file; . . . Có gì thì chỉnh tiếp
Nhấp chuột vào đây để mở rộng...

Anh ơi có một chút vấn đề là khi em chạy vào file thực tế thì báo lỗi. File của anh up lên em thử copy nhân bản thêm 10 sheet nữa thì cũng chạy báo lỗi anh ạ.
For J = 1 To UBound(Arr())

Ngoài sheet BCC thì trong file của em còn các sheet từ 26 đến 31 và 1 đến 25.
 
Lần chỉnh sửa cuối:
Upvote 0
(1) Anh ơi có một chút vấn đề là khi em chạy vào file thực tế thì báo lỗi.
(1.1) File của anh up lên em thử copy nhân bản thêm 10 sheet nữa thì cũng chạy báo lỗi anh ạ.
For J = 1 To UBound(Arr())

(2) Ngoài sheet BCC thì trong file của em còn các sheet từ 26 đến 31 và 1 đến 25.
Nhấp chuột vào đây để mở rộng...

(1) Các tháng khác nhau sẽ có số ngày khác nhau;
Theo như macro thì tháng nào không có các ngày cuối tháng thì trang '31' hay ('30' &/hay '29' (tháng 2)) cần được xóa trang đó đi; Trang nào có công của chí ít 1 nhân viên nào đó mới để lại; Còn không ta fải xóa tất; Có nghĩa là tháng có bao nhiêu ngày thì chỉ tối đa có bí nhiêu trang tính chấm công mà thôi.
(1.1) Nói lại: Ngày nghĩ của CQ, không ai làm thì trang công về ngày đó fải biến khỏi màn hình của Workbook;
(Mình chưa thử, bạn thêm chữ cái nào đó vô đầu của tên trang tính "không công" xem sao?!?)

2. Nếu gán đúng tên thì macro không nề hà với các trang tính í
Nhưng lưu í là sau khi chạy macro, ở 'BCC' các cột dữ liệu thuộc ngày 'trống' đó sẽ f ải không có số liệu)
Có nghĩa là thiết kế trang 'BCC' vẫn giữ í nguyên. (& các ô thuộc cột ghi ngày của chúng củng cần xóa đi hay làm cách nào đó . . . cũng được.

Macro khong căn cứ các ngày đó để chép đâu; Nó căn cứ vô tên trang tính có chấm công để chép mà thôi.


(3) Cũng có thể có thiết kế khác cho 'BCC', nhưng có lẽ lúc đó thuật toán sẽ nhiều fiền toái hơn!
 
Upvote 0
(1) Các tháng khác nhau sẽ có số ngày ....

Vâng chu kỳ lương của công ty em từ 26 tháng trước đến 25 của tháng sau. Ngày nào cũng có người đi làm anh ạ.

(2) Nếu gán đúng tên thì macro không nề hà với các trang tính

Anh thử xem file ChangTQ ở bài #15 chưa ạ? Em chạy ban đầu rất trơn chu, sau đó em thử nhân bản thêm 2 sheet và đặt tên ngày công (cái hay là em đặt tên thoải mái chỉ cần đúng với một trong các ngày được liệt kê ở BCC nó sẽ chuyển đến đúng cái ngày ấy em thấy thật kỳ diệu mà rất tiếc chẳng hiểu sao anh ấy làm được vậy). Sau đó em cho vào file em chạy báo lỗi, em thử nhân bản lên 10 ngày công ở file của anh ấy thì cũng bị lỗi y chang.
 
Lần chỉnh sửa cuối:
Upvote 0
(1) . . .
(2) Nếu gán đúng tên thì macro không nề hà với các trang tính

Anh xem file ChangTQ ở bài #15? Em chạy ban đầu rất trơn tru, sau đó em thử nhân bản thêm 2 sheet và đặt tên ngày công (. . . ). Sau đó em cho vào file em chạy báo lỗi, em thử nhân bản lên 10 ngày công ở file của anh ấy thì cũng bị lỗi y chang.
Nhấp chuột vào đây để mở rộng...

Vậy bạn đưa file báo lỗi í lên diễn đàn đi!

Để các i bác sỹ khám chữa bệnh cho!
Mà nó báo lỗi ra sao?

&&&%$R&&&%$R&&&%$R
 
Upvote 0
SA_DQ đã viết:
Vậy bạn đưa file báo lỗi í lên diễn đàn đi!

Để các i bác sỹ khám chữa bệnh cho!
Mà nó báo lỗi ra sao?

&&&%$R&&&%$R&&&%$R
Nhấp chuột vào đây để mở rộng...

Anh ơi nó báo lỗi runtime erro 6 Overflow. File của em rất nặng, mỗi sheet ngày công lên đến hơn 4000 người. Chỉ khác về dữ liệu còn lại form y chang ở bài 15# anh ạ.

Em xin đính chính file của anh ChangTQ chạy rất mượt :(
 
Lần chỉnh sửa cuối:
Upvote 0
ChanhTQ@ đã viết:
/-)ưa cái file này lên cũng được mà:
Nhấp chuột vào đây để mở rộng...

Vâng của anh thì chạy như ngựa mà không hiểu sao của em thì lại không được, em có đính chínhi ở #24 rồi mà anh. Form thì y chang, chỉ khác là dữ liệu công lớn thôi anh ạ. Có khi nào do lỗi định dạng hoặc phiên bản excel không anh? Của em đang dùng office 2013
 
Lần chỉnh sửa cuối:
Upvote 0
Hay có anh nào có thể sử dụng teamview xem giúp em được không ạ? Em đang cố gắng để có thể chuyển sang mảng lương, điều này quyết định nhiều đến tương lai của em sau này, mong mọi người giúp đỡ!

Hoặc đối với code của anh ChanhTQ

Option Explicit
Sub THCong()
Dim Dat As Date, J As Byte, Rws As Long, Dm As Byte, Ng As Byte, Col As Byte
Dim Cls As Range, Sh As Worksheet, Arr()
Dim ShName As String


Sheets("BCC").Select: Dat = [h6].Value
Rws = [h6].CurrentRegion.Rows.Count
For Each Sh In ThisWorkbook.Worksheets
If IsNumeric(Sh.Name) Then
ShName = ShName & Sh.Name
End If
Next Sh
For Each Cls In Range([B8], [B8].End(xlDown))
ReDim dArr(1 To 1, 1 To 155)
For Dm = 1 To Len(ShName) Step 2
Set Sh = ThisWorkbook.Worksheets(Mid(ShName, Dm, 2))
Ng = CByte(Mid(ShName, Dm, 2))
If Ng > 25 Then
Col = (Ng - 26) * 5 + 1
Else
Col = 26 + Ng * 5
End If
Arr() = Sh.[c9].Resize(Rws, 38).Value
For J = 1 To UBound(Arr())
If Arr(J, 1) = Cls.Value Then
dArr(1, Col) = Arr(J, 33): dArr(1, 1 + Col) = Arr(J, 34)
dArr(1, 2 + Col) = Arr(J, 35): dArr(1, 3 + Col) = Arr(J, 38)
End If
Next J
Next Dm
Cls.Offset(, 6).Resize(, 31 * 5).Value = dArr()
Next Cls
End Sub


Mọi người có thể diễn giải từng dòng lệnh cho em được không ? Ví dụ tại sao là NG - 26 mà không phải số khác, tại sao lại nhân 5 @@
 
Lần chỉnh sửa cuối:
Upvote 0
Anh ChanhTQ ơi công thức này gặp lỗi khi số dòng quá nhiều cụ thể cột ID đến địa chỉ dòng 255 là sẽ lỗi anh ạ.
 
Upvote 0
/)ịch từ ngôn ngữ VBA sang tiếng Việt:

PHP: 
Option Explicit
Sub THCong()
 Dim Dat As Date, J As Byte, Rws As Long, Dm As Byte, Ng As Byte, Col As Byte
 Dim Cls As Range, Sh As Worksheet, Arr()
 Dim ShName As String

1 Sheets("BCC").Select:                          Dat = [h6].Value
 Rws = [h6].CurrentRegion.Rows.Count
3 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
5        ShName = ShName & Sh.Name
    End If
7 Next Sh
 For Each Cls In Range([B8], [B8].End(xlDown))
9    ReDim dArr(1 To 1, 1 To 155)
    For Dm = 1 To Len(ShName) Step 2
11        Set Sh = ThisWorkbook.Worksheets(Mid(ShName, Dm, 2))
        Ng = CByte(Mid(ShName, Dm, 2))
13        If Ng > 25 Then
            Col = (Ng - 26) * 5 + 1
15        Else
            Col = 26 + Ng * 5
17        End If
        Arr() = Sh.[c9].Resize(Rws, 38).Value
19        For J = 1 To UBound(Arr())
            If Arr(J, 1) = Cls.Value Then
21                dArr(1, Col) = Arr(J, 33):      dArr(1, 1 + Col) = Arr(J, 34)
                dArr(1, 2 + Col) = Arr(J, 35):  dArr(1, 3 + Col) = Arr(J, 38)
23            End If
            If Arr(J, 1) = "" Then Exit For     '*'
25        Next J
    Next Dm
27    Cls.Offset(, 6).Resize(, 31 * 5).Value = dArr()
 Next Cls
End Sub

Các dòng lệnh trước D1: Khai báo các biến cần thiết cho chương trình;
D1: Mệnh đề 1: Kích hoạt (chọn) trang tính có tên 'BCC;
Mệnh đề sau: Lấy trị (ngày) tại ô [H6] gán vô biến đã khai báo;
D2: lấy số dòng của vùng dữ liệu xung quanh ô này gán vô biến đã khai báo; (Số dòng này có thể lên đến 2 triệu cũng OK!)
D3: Thiết lập vòng lặp để duyệt qua hết thẩy các trang tính; Vòng lặp này kết thúc tại D7;
D4: Điều kiện: Nếu tên của trang tính đang duyệt là 'Số' thì thực hiện dòng lệnh tiếp ngay sau;
D5: Nối tên trang dăng duyệt vô biến chuỗi đã khai báo
(kết thúc vòng lặp, biến chuỗi này sẽ gồm toàn bộ các trang tính ngày công trong tháng có chấm công)
D6: Kết thúc Đ/K
D8: Tạo vòng lặp duyệt toàn bộ các ô thuộc cột mã NV (cột )
Vòng lặp này kết thúc tại D28;
D9: Khai báo 1 biến mảng gồm 1 dòng & 155 cột; (Ngõ hầu chứa ngày công trong tháng của người mà vòng lặp đang sẽ duyệt
D10: Tạo vòng lặp để duyệt tên từng trang tính (kiểu kí số) trong biến mà vòng lặp đã gôm vô.
Vòng lặp này kết thúc tại D26.
(Thường 1 tháng cao nhất 31 ngày, nên ta chỉ cần biến đe71m 'Dm' không vượt quá 255 đơn vị)
D11: Lấy trang tính có tên biến đếm kiểu số gán vô biến đối tượng (trang tính) Sh đã khai báo;
D12: Lấy tên trang tính này chuyển sang kiểu (dạng) số & ấn vô biến 'Ng'
(Nếu tên trang tính đang là '31', thì Ng sẽ mang số 31 & điều này làm cơ sở để xác định cột cần nạp dữ liệu ngày công vô 'BCC' của người đang được duyệt)
D13: Các câu lệnh kết tiếp (đến trước D18) để xác định cột cần nạp dữ liệu
Ví dụ đang duyệt trang tính '26' thì cột đầu tiên cần nạp sẽ là (26-26)*5+1 (=> 1); Nếu trang '27' sẽ là cột 6,. . .
Vì mỗi người mỗi ngày cần nạp có thể lên tới 4 loại công khác nhau (& 1 loại công nào đó mà bạn sẽ tự nạp) (=> 05 cột cho 1 ngày); Con số 5 là nghĩa như vậy.
D16: Nếu trang ngày công bé hơn 26, thì trang '01' sẽ cách cột để nạp liệu ngày 26 là 26 cột +5 (=>31 cột)
(Xem thêm D27 để rõ hơn chi tiết)
D18: Lấy số liệu của trang ngày công đang duyệt cho vô biến mảng đã khai báo (Arr())
D19: Tạo vòng lặp duyệt dữ liệu vừa đưa vô mảng;
Vòng lặp này kết thúc tại D25;
D20: Nếu khi duyệt (của cả 2 vòng lặp) mà thỏa điều kiện là trùng mã nhân viên đang duyệt của vòng lặp ngoài với mả của trang tính công đang duyệt thì thực hiện các lệnh D21 & D22

Hai dòng lệnh này là lấy số liệu của cột tương ứng của trang ngày công nạp vô biến mảng (mảng 1 dòng & 155 cột)
D24: Kiều kiện để thoát ngay vòng lặp; Khỏi tốn thời gian cho những dòng không số liệu.
D27: Nạp dữ liệu công đã ghi được từ mảng (1 dòng 155 cột) vô dòng đang duyệt của 'BCC'

Cho rằng các biến đếm đã đủ khả năng để đáp ứng số liệu thực tế đề ra;
(Không thể có tháng nào đó > 255 ngày!)
Vậy nên bạn coi lại fần việc của mình; Như khoảng trắng khi tạo tên trang tính; trang tính chấm công ngày 9 của tháng fải là '09' chứ không thể '9' khơi khơi được.
Chuỗi chứa trong ShName sẽ là "26272829303101. . . ."
 
Upvote 0
SA_DQ đã viết:
PHP: 
Option Explicit
Sub THCong()
 Dim Dat As Date, J As Byte, Rws As Long, Dm As Byte, Ng As Byte, Col As Byte
 Dim Cls As Range, Sh As Worksheet, Arr()
 Dim ShName As String

1 Sheets("BCC").Select:                          Dat = [h6].Value
 Rws = [h6].CurrentRegion.Rows.Count
3 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
5        ShName = ShName & Sh.Name
    End If
7 Next Sh
 For Each Cls In Range([B8], [B8].End(xlDown))
9    ReDim dArr(1 To 1, 1 To 155)
    For Dm = 1 To Len(ShName) Step 2
11        Set Sh = ThisWorkbook.Worksheets(Mid(ShName, Dm, 2))
        Ng = CByte(Mid(ShName, Dm, 2))
13        If Ng > 25 Then
            Col = (Ng - 26) * 5 + 1
15        Else
            Col = 26 + Ng * 5
17        End If
        Arr() = Sh.[c9].Resize(Rws, 38).Value
19        For J = 1 To UBound(Arr())
            If Arr(J, 1) = Cls.Value Then
21                dArr(1, Col) = Arr(J, 33):      dArr(1, 1 + Col) = Arr(J, 34)
                dArr(1, 2 + Col) = Arr(J, 35):  dArr(1, 3 + Col) = Arr(J, 38)
23            End If
            If Arr(J, 1) = "" Then Exit For     '*'
25        Next J
    Next Dm
27    Cls.Offset(, 6).Resize(, 31 * 5).Value = dArr()
 Next Cls
End Sub

Các dòng lệnh trước D1: Khai báo các biến cần thiết cho chương trình;
D1: Mệnh đề 1: Kích hoạt (chọn) trang tính có tên 'BCC;
Mệnh đề sau: Lấy trị (ngày) tại ô [H6] gán vô biến đã khai báo;
D2: lấy số dòng của vùng dữ liệu xung quanh ô này gán vô biến đã khai báo; (Số dòng này có thể lên đến 2 triệu cũng OK!)
D3: Thiết lập vòng lặp để duyệt qua hết thẩy các trang tính; Vòng lặp này kết thúc tại D7;
D4: Điều kiện: Nếu tên của trang tính đang duyệt là 'Số' thì thực hiện dòng lệnh tiếp ngay sau;
D5: Nối tên trang dăng duyệt vô biến chuỗi đã khai báo
(kết thúc vòng lặp, biến chuỗi này sẽ gồm toàn bộ các trang tính ngày công trong tháng có chấm công)
D6: Kết thúc Đ/K
D8: Tạo vòng lặp duyệt toàn bộ các ô thuộc cột mã NV (cột )
Vòng lặp này kết thúc tại D28;
D9: Khai báo 1 biến mảng gồm 1 dòng & 155 cột; (Ngõ hầu chứa ngày công trong tháng của người mà vòng lặp đang sẽ duyệt
D10: Tạo vòng lặp để duyệt tên từng trang tính (kiểu kí số) trong biến mà vòng lặp đã gôm vô.
Vòng lặp này kết thúc tại D26.
(Thường 1 tháng cao nhất 31 ngày, nên ta chỉ cần biến đe71m 'Dm' không vượt quá 255 đơn vị)
D11: Lấy trang tính có tên biến đếm kiểu số gán vô biến đối tượng (trang tính) Sh đã khai báo;
D12: Lấy tên trang tính này chuyển sang kiểu (dạng) số & ấn vô biến 'Ng'
(Nếu tên trang tính đang là '31', thì Ng sẽ mang số 31 & điều này làm cơ sở để xác định cột cần nạp dữ liệu ngày công vô 'BCC' của người đang được duyệt)
D13: Các câu lệnh kết tiếp (đến trước D18) để xác định cột cần nạp dữ liệu
Ví dụ đang duyệt trang tính '26' thì cột đầu tiên cần nạp sẽ là (26-26)*5+1 (=> 1); Nếu trang '27' sẽ là cột 6,. . .
Vì mỗi người mỗi ngày cần nạp có thể lên tới 4 loại công khác nhau (& 1 loại công nào đó mà bạn sẽ tự nạp) (=> 05 cột cho 1 ngày); Con số 5 là nghĩa như vậy.
D16: Nếu trang ngày công bé hơn 26, thì trang '01' sẽ cách cột để nạp liệu ngày 26 là 26 cột +5 (=>31 cột)
(Xem thêm D27 để rõ hơn chi tiết)
D18: Lấy số liệu của trang ngày công đang duyệt cho vô biến mảng đã khai báo (Arr())
D19: Tạo vòng lặp duyệt dữ liệu vừa đưa vô mảng;
Vòng lặp này kết thúc tại D25;
D20: Nếu khi duyệt (của cả 2 vòng lặp) mà thỏa điều kiện là trùng mã nhân viên đang duyệt của vòng lặp ngoài với mả của trang tính công đang duyệt thì thực hiện các lệnh D21 & D22

Hai dòng lệnh này là lấy số liệu của cột tương ứng của trang ngày công nạp vô biến mảng (mảng 1 dòng & 155 cột)
D24: Kiều kiện để thoát ngay vòng lặp; Khỏi tốn thời gian cho những dòng không số liệu.
D27: Nạp dữ liệu công đã ghi được từ mảng (1 dòng 155 cột) vô dòng đang duyệt của 'BCC'

Cho rằng các biến đếm đã đủ khả năng để đáp ứng số liệu thực tế đề ra;
(Không thể có tháng nào đó > 255 ngày!)
Vậy nên bạn coi lại fần việc của mình; Như khoảng trắng khi tạo tên trang tính; trang tính chấm công ngày 9 của tháng fải là '09' chứ không thể '9' khơi khơi được.
Chuỗi chứa trong ShName sẽ là "26272829303101. . . ."
Nhấp chuột vào đây để mở rộng...


Dạ vâng em cảm ơn anh nhiều lắm!
Để em kiểm tra lại xem sao, có gì em sẽ báo mọi người
 
Upvote 0
Chào mọi người

Em đã kiểm tra kỹ tất cả, sheet công đều ghi số không có khoảng trắng 26, 27, 28... 01, 02, 03... 25

Sheet BCC cũng không có khoảng trắng.
 
Upvote 0
Anh ChanhTQ ơi công thức này gặp lỗi khi số dòng quá nhiều cụ thể cột ID đến địa chỉ dòng 255 là sẽ lỗi anh ạ.
Nhấp chuột vào đây để mở rộng...

Đúng rồi; Mình xin lỗi nha!

Bạn chuyển khai báo biến J As Long (thay vì As Byte) là được.

 
Upvote 0
Chào mọi người

Em đã kiểm tra kỹ tất cả, sheet công đều ghi số không có khoảng trắng 26, 27, 28... 01, 02, 03... 25

Sheet BCC cũng không có khoảng trắng. Em up file lên mọi người xem giúp em nhé.
 

File đính kèm

Upvote 0
HYen17 đã viết:
Đúng rồi; Mình xin lỗi nha!

Bạn chuyển khai báo biến J As Long (thay vì As Byte) là được.
Nhấp chuột vào đây để mở rộng...

Anh ơi file chạy được rồi, nhưng mà chậm lắm anh ạ dữ liệu ít thì rất nhanh nhưng nhiều thì chậm. Mỗi bảng công có 4000 người lao động. Mà mỗi tháng có 25 đến 26 ngày cônG, em bấm chạy được một lúc xong đơ luôn (em nghĩ nó vẫn đang chạy). Có cách nào để nhanh hơn không ạ?
 
Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
Anh ơi file chạy được rồi, nhưng mà chậm lắm anh ạ dữ liệu ít thì rất nhanh nhưng nhiều thì chậm. Mỗi bảng công có 4000 người lao động. Mà mỗi tháng có 25 đến 26 ngày cônG, em bấm chạy được một lúc xong đơ luôn (em nghĩ nó vẫn đang chạy). Có cách nào để nhanh hơn không ạ?
Nhấp chuột vào đây để mở rộng...
Bạn sắp xếp lại ID bên sheet BCC theo từ nhỏ đến lớn và chạy code này coi, nếu ok thì tính tiếp
Mã: 
Sub test()
Dim cn As Object, rs As Object
Set cn = CreateObject("ADODB.Connection")
 cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
 Set rs = cn.Execute("select b.f33, b.f34,b.f35, '', b.f38 from [BCC$B8:B3466] a left join [26$C9:AN3467] b on b.f1 = a.f1")
Range("H8").CopyFromRecordset rs
End Sub
 
Upvote 0
Bạn thử macro này trên file thật của bạn xem tiêu tốn mấy trăm gy cho 220 người
PHP: 
Option Explicit
Sub ArrTHCong()
 Dim W As Long, J As Long, Rws As Long, Dm As Byte, Ng As Byte, Col As Byte, Tmr As Double
 Dim Rng As Range, Sh As Worksheet, Arr(), Aid()
 Dim ShName As String
 
 Sheets("BCC").Select:                      Tmr = Timer()
 Rws = [h6].CurrentRegion.Rows.Count
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        ShName = ShName & Sh.Name
    End If
 Next Sh
 Set Rng = Range([B8], [B8].End(xlDown))
 Aid() = Rng.Value
 ReDim dArr(1 To Rng.Rows.Count, 1 To 155)
 For J = 1 To UBound(Aid())
    For Dm = 1 To Len(ShName) Step 2
        Set Sh = ThisWorkbook.Worksheets(Mid(ShName, Dm, 2))
        Ng = CByte(Mid(ShName, Dm, 2))
        If Ng > 25 Then
            Col = (Ng - 26) * 5 + 1
        Else
            Col = 26 + Ng * 5
        End If
        Arr() = Sh.[c9].Resize(Rws, 38).Value
        For W = 1 To UBound(Arr())
            If Aid(J, 1) = Arr(W, 1) Then
                dArr(J, Col) = Arr(W, 33):      dArr(J, 1 + Col) = Arr(W, 34)
                dArr(J, 2 + Col) = Arr(W, 35):  dArr(J, 3 + Col) = Arr(W, 38)
            End If
        Next W
    Next Dm
    
    If J = 220 Then GoTo GPE
 Next J
GPE:
 [H8].Resize(J, 155).Value = dArr()
 MsgBox Timer() - Tmr
End Sub
 
Upvote 0
ChanhTQ@ đã viết:
Bạn thử macro này trên file thật của bạn xem tiêu tốn mấy trăm gy cho 220 người
PHP: 
Option Explicit
Sub ArrTHCong()
 Dim W As Long, J As Long, Rws As Long, Dm As Byte, Ng As Byte, Col As Byte, Tmr As Double
 Dim Rng As Range, Sh As Worksheet, Arr(), Aid()
 Dim ShName As String
 
 Sheets("BCC").Select:                      Tmr = Timer()
 Rws = [h6].CurrentRegion.Rows.Count
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        ShName = ShName & Sh.Name
    End If
 Next Sh
 Set Rng = Range([B8], [B8].End(xlDown))
 Aid() = Rng.Value
 ReDim dArr(1 To Rng.Rows.Count, 1 To 155)
 For J = 1 To UBound(Aid())
    For Dm = 1 To Len(ShName) Step 2
        Set Sh = ThisWorkbook.Worksheets(Mid(ShName, Dm, 2))
        Ng = CByte(Mid(ShName, Dm, 2))
        If Ng > 25 Then
            Col = (Ng - 26) * 5 + 1
        Else
            Col = 26 + Ng * 5
        End If
        Arr() = Sh.[c9].Resize(Rws, 38).Value
        For W = 1 To UBound(Arr())
            If Aid(J, 1) = Arr(W, 1) Then
                dArr(J, Col) = Arr(W, 33):      dArr(J, 1 + Col) = Arr(W, 34)
                dArr(J, 2 + Col) = Arr(W, 35):  dArr(J, 3 + Col) = Arr(W, 38)
            End If
        Next W
    Next Dm
    
    If J = 220 Then GoTo GPE
 Next J
GPE:
 [H8].Resize(J, 155).Value = dArr()
 MsgBox Timer() - Tmr
End Sub
Nhấp chuột vào đây để mở rộng...

Hết 22s anh ạ. Chạy trên 31 sheet ngày công. Hay anh có rảnh không em bật teamview anh xem cho em nhé.
Em mới phát hiện ra nó không quét hết dữ liệu, ví dụ công ngày 09 rõ ràng là có nhưng khi tổng hợp thì lại không có. Các ID trong các sheet chấm công nó không theo quy luật thứ tự nào mà xáo trộn thì có ảnh hưởng gì không anh?
 
Lần chỉnh sửa cuối:
Upvote 0
quanluu1989 đã viết:
Bạn sắp xếp lại ID bên sheet BCC theo từ nhỏ đến lớn và chạy code này coi, nếu ok thì tính tiếp
Mã: 
Sub test()
Dim cn As Object, rs As Object
Set cn = CreateObject("ADODB.Connection")
 cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
 Set rs = cn.Execute("select b.f33, b.f34,b.f35, '', b.f38 from [BCC$B8:B3466] a left join [26$C9:AN3467] b on b.f1 = a.f1")
Range("H8").CopyFromRecordset rs
End Sub
Nhấp chuột vào đây để mở rộng...

Tốc độ rất nhanh nhưng không đúng. Cột ID tổng của em là tập hợp ID của tất cả các sheet công (có thể ID sheet công của ngày này lại không có trong ngày khác).
 
Upvote 0
Hết 22s anh ạ. Chạy trên 31 sheet ngày công. Hay anh có rảnh không em bật teamview anh xem cho em nhé.
(1) Em mới phát hiện ra nó không quét hết dữ liệu, ví dụ công ngày 09 rõ ràng là có nhưng khi tổng hợp thì lại không có.
(2) Các ID trong các sheet chấm công nó không theo quy luật thứ tự nào mà xáo trộn thì có ảnh hưởng gì không anh?
Nhấp chuột vào đây để mở rộng...

(1) Điều này là lạ đó nghe; Để hiểu tại sao vậy, ta cần 2 câu lệnh

MsgBox ShName
Exit Sub
sau dòng lệnh
Next Sh
để xem trong biến có chứa chuỗi 09 chưa.

(Cũng cần đề fòng trường hợp trang '09' đó không chứa ai trong 220 người đã được macro xử lí nữa nha.)

(2) Không ảnh hưởng nhiều lắm đến tốc độ xử lí thôi; Chứ kết quả vẫn đúng.

(3) Vậy là máy của bạn gấp gần chục lần máy mình rồi
Để chạy hết chương trình thì bạn bỏ hay vô hiệu hóa dòng lệnh
Mã: 
If J = 220 Then GoTo GPE
ấy đi!
 
Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
Tốc độ rất nhanh nhưng không đúng. Cột ID tổng của em là tập hợp ID của tất cả các sheet công (có thể ID sheet công của ngày này lại không có trong ngày khác).
Nhấp chuột vào đây để mở rộng...
Mình hiểu cái đó, bạn có thể chỉ ra cái nào ko đúng ko? bạn thử thay "on b.f1 = a.f1" bằng on b.f1 = a.f1 order by a.f1 coi có chuẩn ko?
 
Upvote 0
Anh SA ơi anh đã ngủ chưa ạ? Máy em bị đơ hẳn rồi :(. Có thuật toán nào nhanh hơn không anh?
 
Lần chỉnh sửa cuối:
Upvote 0
Anh ơi? Máy em bị đơ hẳn rồi :(. Có thuật toán nào nhanh hơn không anh?
Nhấp chuột vào đây để mở rộng...

Trong khi chờ đợi giải thuật khả dĩ hơn từ cộng đồng , bạn có thể tăng dần số người xử lý lên xem sao; Ví dụ
PHP: 
Số người | Thời gian
   220    |   23"                   "
   500    |   ?
   999    |   ??
  1500    |  ???
  2000    | ???
 
Upvote 0
Hiện tại mình vẫn chưa biết code mà bạn bảo là bị sai chỗ nào, nhưng cứ đưa code tổng quát lên để bạn tham khảo
Mã: 
Sub test()
Dim cn As Object, sh As Worksheet
Dim i As Integer, timm As Double
timm = Timer
Set cn = CreateObject("ADODB.Connection")
With cn
    For Each sh In ThisWorkbook.Sheets
        .Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
        If sh.Name <> "BCC" Then
            For i = 8 To 158
                If Sheets("BCC").Cells(6, i) <> "" And Day(Sheets("BCC").Cells(6, i)) = Val(sh.Name) Then
                    Sheets("BCC").Cells(8, i).CopyFromRecordset .Execute("select b.f33, b.f34,b.f35, '', b.f38 from [BCC$B8:B3466] a left join [" & sh.Name & "$C9:AN4000] b on b.f1 = a.f1")
                    Exit For
                End If
            Next
        End If
        .Close
    Next
End With
Set cn = Nothing
MsgBox (Timer - timm)
End Sub
 
Upvote 0
Mã: 
        If Sheets("BCC").Cells(6, i) <> "" And Day(Sheets("BCC").Cells(6, i)) = Val(sh.Name) Then
           
        End If
Nhấp chuột vào đây để mở rộng...

Theo mình nghĩ thì cău lệnh If này tiềm ẩn nguy cơ sai fạm do thiết kế trang 'BCC' đem lại;
Thứ nhất: Các ngày trong các tháng là khác nhau;
Cho nên tại dòng 6 của 'BCC' từ cột [H] trở về sau không nên là số liệu ngày tháng; mà chỉ nên là số liệu ngày (của bất kì tháng nào trong năm)
Ví dụ 26, 27, 28, . . . . . .
& như thế, tháng nào chỉ 29 ngày thì các cột thuộc về ngày 30 hay 31 sẽ không được chương trình nhập số liệu

Nếu không là cách này thì cách khác sẽ fức tạp hơn; Như ta luôn ghi ngày 01 của tháng chấm công cố định vô cột [AL]; Ngày trước ngày 01 này sẽ fải ở cột [AG], cho dù nó là ngày nào của cuối tháng trước

Thứ hai: . . . . . (sẽ viết) --=0 --=0 --=0
 
Upvote 0
SA_DQ đã viết:
Theo mình nghĩ thì cău lệnh If này tiềm ẩn nguy cơ sai fạm do thiết kế trang 'BCC' đem lại;
Thứ nhất: Các ngày trong các tháng là khác nhau;
Cho nên tại dòng 6 của 'BCC' từ cột [H] trở về sau không nên là số liệu ngày tháng; mà chỉ nên là số liệu ngày (của bất kì tháng nào trong năm)
Ví dụ 26, 27, 28, . . . . . .
& như thế, tháng nào chỉ 29 ngày thì các cột thuộc về ngày 30 hay 31 sẽ không được chương trình nhập số liệu

Nếu không là cách này thì cách khác sẽ fức tạp hơn; Như ta luôn ghi ngày 01 của tháng chấm công cố định vô cột [AL]; Ngày trước ngày 01 này sẽ fải ở cột [AG], cho dù nó là ngày nào của cuối tháng trước

Thứ hai: . . . . . (sẽ viết) --=0 --=0 --=0
Nhấp chuột vào đây để mở rộng...
Mình vẫn chưa hiểu hết ý của bạn, thực chất ban đầu mình chỉ viết "Day(Sheets("BCC").Cells(6, i)) = Val(sh.Name)" thui nhưng thấy day(cell rông) = 30 nên mình phải thêm đk khác rỗng

Còn mình nghĩ cái này đọc theo tên sheet trc, sau đó dò date nào có ngày trùng với tên sheet thì điền kết quả. nên mình vẫn chưa nhìn thấy có vấn đề gì ở dòng If này cả.
 
Upvote 0
quanluu1989 đã viết:
Mình vẫn chưa thấy bạn nêu ra ví dụ không đủ chỗ nào, ko đúng chỗ nào. Mình test với fiile mẫu của bạn thì thấy có vấn đề gì đâu nhỉ?
Nhấp chuột vào đây để mở rộng...

File chạy đến dòng 3400 thì không thấy quét dữ liệu vào nữa. Các dòng ở trên cũng chỉ quét đôi ngày chứ không đầy đủ.
 
Upvote 0
tueyennhi đã viết:
File chạy đến dòng 3400 thì không thấy quét dữ liệu vào nữa. Các dòng ở trên cũng chỉ quét đôi ngày chứ không đầy đủ.
Nhấp chuột vào đây để mở rộng...
Bạn đã check với file bạn đính kèm mẫu chưa? hay bạn check luôn với file thật của bạn?
Mình đã check với file mẫu đính kèm thì ra toàn bộ kêt quả. Nếu bạn ko ngại thì bạn up lên 1 it dữ liệu file thật, như thế mới biết đc vấn đề.
 
Upvote 0
Bạn có thể chạy với macro này trong khi chờ những cái khác tốt hơn:
PHP: 
Option Explicit
Sub FindTHCong()
 Dim W As Long, J As Long, Rws As Long, Dm As Byte, Ng As Byte, Col As Byte, Tmr As Double
 Dim Rng As Range, Sh As Worksheet, Arr(), sRng As Range
 Dim ShName As String
 
 Sheets("BCC").Select:                      Tmr = Timer()
 Rws = [h6].CurrentRegion.Rows.Count
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        ShName = ShName & Sh.Name
    End If
 Next Sh
 Set Rng = Range([B8], [B8].End(xlDown))
 Arr() = Rng.Value
 ReDim dArr(1 To Rng.Rows.Count, 1 To 155)
 For J = 1 To UBound(Arr())
    For Dm = 1 To Len(ShName) Step 2
        Set Sh = ThisWorkbook.Worksheets(Mid(ShName, Dm, 2))
        Ng = CByte(Mid(ShName, Dm, 2))
        If Ng > 25 Then
            Col = (Ng - 26) * 5 + 1
        Else
            Col = 26 + Ng * 5
        End If
        Set Rng = Sh.Range(Sh.[C9], Sh.[C9].End(xlDown))
        Set sRng = Rng.Find(Arr(J, 1), , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            dArr(J, Col) = sRng.Offset(, 32).Value
            dArr(J, Col + 1) = sRng.Offset(, 33).Value
            dArr(J, Col + 2) = sRng.Offset(, 34).Value
            dArr(J, Col + 3) = sRng.Offset(, 37).Value
        End If
    Next Dm
 Next J
 [H8].Resize(J, 155).Value = dArr()
 MsgBox Timer() - Tmr
End Sub
 
Upvote 0
ChanhTQ@ đã viết:
Bạn có thể chạy với macro này trong khi chờ những cái khác tốt hơn:

End Sub...
Nhấp chuột vào đây để mở rộng...

Thuật toán đã nhanh hơn nhiều cụ thể

220 người mất 9s
500 người mất 18s
1000 người mất 43s
2000 người mất 82s
4200 người mất 195s

Như vậy là đã quá nhanh rồi anh ạ, cảm ơn anh nhé. Dữ liệu check xác suất không thấy sai cái nào :(

Sau khi chỉnh sửa thêm dòng lệnh

dArr(J, Col) = sRng.Offset(, 32).Value
dArr(J, Col + 1) = sRng.Offset(, 33).Value
dArr(J, Col + 2) = sRng.Offset(, 34).Value
dArr(J, Col + 3) = sRng.Offset(, 35).Value
dArr(J, Col + 4) = sRng.Offset(, 37).Value

Thời gian có tăng thêm một chút mất 228s như vậy là tuyệt rồi anh ạ, có một thắc mắc là ở dòng cuối cùng sẽ để lại giá trị #n/a là sao anh nhỉ?
 
Lần chỉnh sửa cuối:
Upvote 0
; Có một thắc mắc là ở dòng cuối cùng sẽ để lại giá trị #n/a là sao anh nhỉ?
Nhấp chuột vào đây để mở rộng...
Để khắc fục hiện tượng này, bạn sửa câu lệnh liên quan lại như sau:
Mã: 
[H8].Resize(J - 1, 155).Value = dArr()

À có thể thêm 1 câu lệnh này
PHP: 
If Arr(J, 1) = "" Then Exit For
vô sau dòng
Mã: 
For J = 1 To UBound(Arr())
cho có vẻ chuyên nghiệp!

Chúc vui!
 
Upvote 0
Dạ vâng anh, giá được làm đệ của anh thì tốt biết mấy, em sẽ học hỏi được nhiều!

Cho em hỏi thêm dòng lệnh sau

Sub Lay_ID()
Dim Dic, ws As Worksheet, iRow As Long, i As Long, Arr(), TmpArr, Tmp
On Error Resume Next
Application.ScreenUpdating = False
Sheet25.Range("b8:b5000").ClearContents
Set Dic = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
If ws.Name <> Sheet25 Then
TmpArr = ws.Range(ws.[c8], ws.[c5000].End(xlUp)).Value
For iRow = 1 To UBound(TmpArr, 1)
Tmp = TmpArr(iRow, 1)
If Not IsEmpty(Tmp) Then
If Not Dic.Exists(Tmp) Then
Dic.Add Tmp, ""
i = i + 1
ReDim Preserve Arr(1 To 1, 1 To i)
Arr(1, i) = TmpArr(iRow, 1)
'.................................
End If
End If
Next
End If
Next
With Sheet25
.Range("b8").Resize(i, 1) = WorksheetFunction.Transpose(Arr)


End With
Application.ScreenUpdating = True
End Sub

Dùng để tổng hợp toàn bộ ID từ các sheet công. Nhưng em thấy có gì đó sai bởi vì luôn xuất hiện ID có tên là Name mặc dù toàn bộ cột ID của trang tính công em không thấy giá trị Name nào cả. Theo em hiểu thì dòng lệnh quét cột ID của các sheet chấm công từ C8 đến C5000. Có đúng như vậy không ạ? Như vậy thì ở BCC phải có ID là ID chứ sao lại là Name? @@
 
Lần chỉnh sửa cuối:
Upvote 0
Tôi không theo dõi các bài viết đầy đủ, chỉ hiểu và làm theo file đính kèm bài #33 của bạn.
Xem thử kết quả thế nào nhé.
 

File đính kèm

Upvote 0
. . . chỉ hiểu và làm theo file đính kèm bài #33 của bạn.
Xem thử kết quả thế nào nhé.
Nhấp chuột vào đây để mở rộng...
Một khi trang 'BCC' là 4.200 dòng & 31 trang chấm công có cở 3.800-4.000 dòng là biết nhau ngay í mà;

Biết rằng trong 31 trang chấm công í, thì trong 1.850 dòng trung bình í chỉ đi tìm 1 dòng có đúng mã thôi;
Vế điều này thì tìm trong mảng lại chậm hơn fương thức FIND(); Mình vừa thử xong sáng nay mới dám khẳng định như vậy!
--=0 ;;;;;;;;;;; --=0
 
Upvote 0
SA_DQ đã viết:
Một khi trang 'BCC' là 4.200 dòng & 31 trang chấm công có cở 3.800-4.000 dòng là biết nhau ngay í mà;

Biết rằng trong 31 trang chấm công í, thì trong 1.850 dòng trung bình í chỉ đi tìm 1 dòng có đúng mã thôi;
Vế điều này thì tìm trong mảng lại chậm hơn fương thức FIND(); Mình vừa thử xong sáng nay mới dám khẳng định như vậy!
--=0 ;;;;;;;;;;; --=0
Nhấp chuột vào đây để mở rộng...

Chả hiểu anh nói gì +-+-+-+ thế cái này hơn à anh -\\/.
 
Upvote 0
Chả hiểu anh nói gì thế cái này hơn à anh
Nhấp chuột vào đây để mở rộng...
Vì macro í chỉ chạy trên 2 trang tính thôi; nếu đủ 31+1 trang sẽ khác đó;
Còn đây là macro lập danh sách duy nhất từ 31 trang chấm công nè:
PHP: 
Option Explicit
Sub LapDSDuyNhatTu31Trang()
 Dim Rw As Long, W As Long, J As Long
 Dim TmpArr(), Dic1 As Object, Sh As Worksheet
 Set Dic1 = CreateObject("Scripting.Dictionary")
 ReDim Arr(1 To 5000, 1 To 1) As Long
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        TmpArr() = Sh.Range(Sh.[c9], Sh.[c9].End(xlDown)).Value
        For J = 1 To UBound(TmpArr())
            If Not Dic1.exists(TmpArr(J, 1)) Then
                W = W + 1:          Arr(W, 1) = TmpArr(J, 1)
                Dic1.Add TmpArr(J, 1), W
            End If
        Next J
    End If
 Next Sh
 If W Then
    Sheets("BCC").[b8].Resize(W).Value = Arr()
 End If
End Sub
 
Upvote 0
HYen17 đã viết:
Vì macro í chỉ chạy trên 2 trang tính thôi; nếu đủ 31+1 trang sẽ khác đó;
Còn đây là macro lập danh sách duy nhất từ 31 trang chấm công nè:
PHP: 
Option Explicit
Sub LapDSDuyNhatTu31Trang()
 Dim Rw As Long, W As Long, J As Long
 Dim TmpArr(), Dic1 As Object, Sh As Worksheet
 Set Dic1 = CreateObject("Scripting.Dictionary")
 ReDim Arr(1 To 5000, 1 To 1) As Long
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        TmpArr() = Sh.Range(Sh.[c9], Sh.[c9].End(xlDown)).Value
        For J = 1 To UBound(TmpArr())
            If Not Dic1.exists(TmpArr(J, 1)) Then
                W = W + 1:          Arr(W, 1) = TmpArr(J, 1)
                Dic1.Add TmpArr(J, 1), W
            End If
        Next J
    End If
 Next Sh
 If W Then
    Sheets("BCC").[b8].Resize(W).Value = Arr()
 End If
End Sub
Nhấp chuột vào đây để mở rộng...


Em chạy trên 31 trang tính mà anh?? Hết hơn 3s. Nói gì thì nói với cái xã hội nhà nước bây giờ khi lên forum mình được bao thế hệ đàn anh giúp đỡ em cảm thấy thật xúc động. Cái này là suy nghĩ thật của em (em vừa tu rượu với bố vợ em trai). Cảm ơn mọi người rất nhiều!
 
Upvote 0
HYen17 đã viết:
Vì macro í chỉ chạy trên 2 trang tính thôi; nếu đủ 31+1 trang sẽ khác đó;
Còn đây là macro lập danh sách duy nhất từ 31 trang chấm công nè:
PHP: 
Option Explicit
Sub LapDSDuyNhatTu31Trang()
 Dim Rw As Long, W As Long, J As Long
 Dim TmpArr(), Dic1 As Object, Sh As Worksheet
 Set Dic1 = CreateObject("Scripting.Dictionary")
 ReDim Arr(1 To 5000, 1 To 1) As Long
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        TmpArr() = Sh.Range(Sh.[c9], Sh.[c9].End(xlDown)).Value
        For J = 1 To UBound(TmpArr())
            If Not Dic1.exists(TmpArr(J, 1)) Then
                W = W + 1:          Arr(W, 1) = TmpArr(J, 1)
                Dic1.Add TmpArr(J, 1), W
            End If
        Next J
    End If
 Next Sh
 If W Then
    Sheets("BCC").[b8].Resize(W).Value = Arr()
 End If
End Sub
Nhấp chuột vào đây để mở rộng...
code của bạn Ba Tê không cần có danh sách cột B, làm 2 việc tạo danh sách và lấy dữ liệu chấm công
muốn chạy code của bạn SA_DQ phải có danh sách cột B, nếu chưa có phải dùng code của bạn, và phải duyệt qua tất cả các dòng của 31 sheet chấm công
 
Lần chỉnh sửa cuối:
Upvote 0
Em chạy trên 31 trang tính mà anh?? Hết hơn 3s. . . . Cảm ơn mọi người rất nhiều!
Nhấp chuột vào đây để mở rộng...

Vậy hả; Mình thấy chỉ 2 trang tính trong file thầy 3 Tê nên nói vậy; Chứ thật ra mình chưa thử!
 
Upvote 0
Cho em hỏi ngoài lề một chút về tính tổng có điều kiện. Mọi người xem file nhé.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Cố đuổi theo Thầy Ba Tê cái coi:
PHP: 
Option Explicit
Sub TongHopTu31Trang()
 Dim Rw As Long, W As Long, J As Long, Ng As Byte, Col As Byte, Tmr As Double
 Dim TmpArr(), Dic1 As Object, Sh As Worksheet
 Set Dic1 = CreateObject("Scripting.Dictionary")
 ReDim Arr(1 To 5000, 1 To 161):                    Tmr = Timer()
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        TmpArr() = Sh.Range(Sh.[c9], Sh.[c9].End(xlDown)).Resize(, 38).Value
        Ng = CByte(Sh.Name)
        If Ng > 25 Then
            Col = (Ng - 25) * 5 + 2
        Else
            Col = 32 + Ng * 5
        End If
        For J = 1 To UBound(TmpArr())
            If Not Dic1.exists(TmpArr(J, 1)) Then
                W = W + 1:                          Arr(W, 1) = TmpArr(J, 1)
                Arr(W, 2) = TmpArr(J, 2):           Dic1.Add TmpArr(J, 1), W
                
                Arr(W, Col) = TmpArr(J, 33):        Arr(W, Col + 1) = TmpArr(J, 34)
                Arr(W, Col + 2) = TmpArr(J, 35):    Arr(W, Col + 3) = TmpArr(J, 36)
                Arr(W, Col + 4) = TmpArr(J, 38)
            Else
                Arr(Dic1.Item(TmpArr(J, 1)), Col) = TmpArr(J, 33)
                Arr(Dic1.Item(TmpArr(J, 1)), Col + 1) = TmpArr(J, 34)
                Arr(Dic1.Item(TmpArr(J, 1)), Col + 2) = TmpArr(J, 35)
                Arr(Dic1.Item(TmpArr(J, 1)), Col + 3) = TmpArr(J, 36)
                Arr(Dic1.Item(TmpArr(J, 1)), Col + 4) = TmpArr(J, 38)
            End If
        Next J
    End If
 Next Sh
 If W Then
    Sheets("BCC").[b8].Resize(W, 161).Value = Arr()
    Sheets("BCC").[g1].Value = Timer() - Tmr
 End If
End Sub
 
Upvote 0
ChanhTQ@ đã viết:
Cố đuổi theo Thầy Ba Tê cái coi:

Sao Anh không lấy luôn cột B?
PHP: 
Sub TongHopTu31Trang()
 Dim Rw As Long, W As Long, J As Long, Ng As Byte, Col As Byte, Tmr As Double
 Dim TmpArr(), Dic1 As Object, Sh As Worksheet
 Set Dic1 = CreateObject("Scripting.Dictionary")
 ReDim Arr(1 To 5000, 1 To 161):                    Tmr = Timer()
 For Each Sh In ThisWorkbook.Worksheets
    If IsNumeric(Sh.Name) Then
        TmpArr() = Sh.Range(Sh.[c9], Sh.[c9].End(xlDown)).Resize(, 38).Value
        Ng = CByte(Sh.Name)
        If Ng > 25 Then
            Col = (Ng - 25) * 5 + 2
        Else
            Col = 32 + Ng * 5
        End If
        For J = 1 To UBound(TmpArr())
            If Not Dic1.exists(TmpArr(J, 1)) Then
                W = W + 1: Dic1.Add TmpArr(J, 1), W:    Arr(W, 1) = TmpArr(J, 1)
            End If
            Rw = Dic1.Item(TmpArr(J, 1))
                Arr(Rw, Col) = TmpArr(J, 33)
                Arr(Rw, Col + 1) = TmpArr(J, 34):       Arr(Rw, Col + 2) = TmpArr(J, 35)
                Arr(Rw, Col + 3) = TmpArr(J, 36):       Arr(Rw, Col + 4) = TmpArr(J, 38)
        Next J
    End If
 Next Sh
 If W Then
    Sheets("BCC").[b8].Resize(W, 161).Value = Arr()
    Sheets("BCC").[g1].Value = Timer() - Tmr
 End If
Set Dic1=Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
Cột trong các trang (để chấm công các ngày trong tháng) là thừa;
Mà chuyển từ tên trang tính sang cột (cho Array) cũng dễ mà!
 
Upvote 0
Khi tôi chưa biết vba là gì, tôi phải học lóm của ChanhTQ@, nhất là "Chị" HYen17. Sau đó là học "chỉa" từ GPE. "GPE BAO LA".
 
Upvote 0
Ba Tê đã viết:
Khi tôi chưa biết vba là gì, tôi phải học lóm của ChanhTQ@, nhất là "Chị" HYen17. Sau đó là học "chỉa" từ GPE. "GPE BAO LA".
Nhấp chuột vào đây để mở rộng...

ChanhTQ là Trần Quốc Chanh à anh --=0, có phải anh ở Hưng Yên không? Để đạt đến trình độ cao như bây giờ thầy Ba Tê đã học như thế nào? Em thì chỉ đụng cái nào học cái đấy, không hiểu cốt lõi, ví dụ như code của thầy

dArr(Rws, C + 1) = sArr(I, 34) chỉ hiểu mỗi thay dữ liệu để lấy cột mong muốn còn lại em mù tịt.+-+-+-+
 
Upvote 0
Ba Tê đã viết:
Tôi không theo dõi các bài viết đầy đủ, chỉ hiểu và làm theo file đính kèm bài #33 của bạn.
Xem thử kết quả thế nào nhé.
Nhấp chuột vào đây để mở rộng...

ANh Ba tê ơi cho em hỏi thêm, sau khi đã tổng hợp dữ liệu rồi, em có file ngày nghỉ muốn update riêng vào cột WD của sheet BCC Anh xem file đính kèm giúp em nhé.


Em cảm ơn!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Mọi người cho em hỏi chút em viết như vậy sai ở đâu mà không chạy

PHP: 
Option Explicit


Public Sub GPE()
Dim Dic As Object, Col As Object, Ws As Worksheet, Tem As String, Rws As Long
Dim sArr(), dArr(1 To 5000, 1 To 162), I As Long, J As Long, K As Long, C As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Sheets("BCC")
sArr = .Range("B6").Resize(, 162).Value
For J = 1 To 162
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
End With
For Each Ws In Worksheets
If Ws.Name = "N" Then
C = Col.Item(Val(Ws.Name))
sArr = Ws.Range("C9", Ws.Range("C9").End(xlDown)).Resize(, 38).Value
For I = 1 To UBound(sArr)
Tem = sArr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(I, 1)
End If
Rws = Dic.Item(Tem)
dArr(Rws, C) = sArr(I, 33)
dArr(Rws, C + 1) = sArr(I, 34)
dArr(Rws, C + 2) = sArr(I, 35)
dArr(Rws, C + 3) = sArr(I, 36)
dArr(Rws, C + 4) = sArr(I, 38)
Next I
End If
Next Ws
Sheets("BCC").Range("B8").Resize(K, 162) = dArr
Set Dic = Nothing
Set Col = Nothing
End Sub

Code này của anh Ba tê, em sửa lại để up thêm thông tin từ sheet N, nhưng nó không chạy. Mục đích là update thêm giá trị nghỉ em cần ở sheet N. Em đã cố tìm hiểu về Scriptinh Dictionary nhưng vẫn chưa hiểu được để có thể thay đổi áp dụng cho đúng chứ không phải em y lại mọi người, mong mọi người giúp sức, công việc của em được 60% rồi! Mọi người xem ở file Update nhé, file kia em không gỡ được.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
Mọi người cho em hỏi chút em viết như vậy sai ở đâu mà không chạy
...
Code này của anh Ba tê, em sửa lại để up thêm thông tin từ sheet N, nhưng nó không chạy. Mục đích là update thêm giá trị nghỉ em cần ở sheet N.
Nhấp chuột vào đây để mở rộng...
Góp ý với bạn tueyennhi,
Bạn nên để code/ công thức vào thẻ
Mã: 
 hoặc [PHP]
 
Upvote 0
Bài bị trôi, nhờ mọi người xem bài #76 giúp em nhé!
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn thử Code sau để xem dòng lệnh số 17 của bạn nó xác định vùng ở đâu (Chưa nói là câu lệnh này còn sai cú pháp Exc linh động cố chạy đấy):

Mã: 
Sub Test()
        Sheet2.Range("C9", Sheet2.Range("C9").End(xlDown)).Resize(, 38).Select
End Sub

Mình thấy câu lệnh

Mã: 
If Ws.Name <> "BCC" And Ws.Name = "N" Then


nó chỉ cần

Mã: 
 If Ws.Name = "N" Then

Bạn kiểm tra lại, vì mình không theo dõi từ đầu nên không biết bạn làm gì nên không kiểm tra hoạt động được
 
Lần chỉnh sửa cuối:
Upvote 0
sealand đã viết:
Bạn thử Code sau để xem dòng lệnh số 17 của bạn nó xác định vùng ở đâu (Chưa nói là câu lệnh này còn sai cú pháp Exc linh động cố chạy đấy):

Mã: 
Sub Test()
        Sheet2.Range("C9", Sheet2.Range("C9").End(xlDown)).Resize(, 38).Select
End Sub

Mình thấy câu lệnh

Mã: 
If Ws.Name <> "BCC" And Ws.Name = "N" Then


nó chỉ cần

Mã: 
 If Ws.Name = "N" Then

Bạn kiểm tra lại, vì mình không theo dõi từ đầu nên không biết bạn làm gì nên không kiểm tra hoạt động được
Nhấp chuột vào đây để mở rộng...

Bạn xem cho mình file tổng hợp công ban đầu của anh Bate nhé, code bao gồm 2 sheet minh họa, thực tế thì bao gồm sheet tổng hợp là BCC và các sheet công từ ngày 26 tháng này đến 25 tháng sau (1 chu kỳ lương) và anh ấy viết cho mình file lấy dữ liệu đáp ứng được yêu cầu như sau:

1. Quét toàn bộ ID của các sheet công (26, 27, 28, 29... 01, 02, 03...24, 25) và lấy ra 1 danh sách ID đại diện duy nhất cho vào BCC. (ví dụ sheet 26 có các ID 10, 20, 30 và sheet 27 có các ID 20, 30, 40 thì sheet BCC cột ID sẽ là 10, 20, 30, 40).
2. Sau đó căn cứ vào ID và ngày công mà update dữ liệu công tương ứng vào BCC (ví dụ công ngày 26 sẽ lấy dữ liệu từ sheet 26 và đổ vào cột công của ngày 26 trong sheet BCC.


Còn hiện tại mình muốn sau khi đã tổng hợp công trong BCC xong, mình update tiếp thông tin ngày nghỉ dựa vào sheet N. Cột lý do nghỉ sẽ tự động điền vào cột WD của ngày công tương ứng. Trong code GPE mình sửa code của anh Bate từ If Ws.Name <> "BCC" thành If Ws.Name <> "BCC" And Ws.Name <> "N" vì nếu không sửa vậy thì code nó không chạy do mình thêm sheet N.

Mình biết chắc code sẽ không chạy bởi vì form nhập dữ liệu update nó khác hoàn toàn so với sheet công (26).
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
Bạn xem cho mình file tổng hợp công ban đầu của anh Bate nhé, code bao gồm 2 sheet minh họa, thực tế thì bao gồm sheet tổng hợp là BCC và các sheet công từ ngày 26 tháng này đến 25 tháng sau (1 chu kỳ lương) và anh ấy viết cho mình file lấy dữ liệu đáp ứng được yêu cầu như sau:

1. Quét toàn bộ ID của các sheet công (26, 27, 28, 29... 01, 02, 03...24, 25) và lấy ra 1 danh sách ID đại diện duy nhất cho vào BCC. (ví dụ sheet 26 có các ID 10, 20, 30 và sheet 27 có các ID 20, 30, 40 thì sheet BCC cột ID sẽ là 10, 20, 30, 40).
2. Sau đó căn cứ vào ID và ngày công mà update dữ liệu công tương ứng vào BCC (ví dụ công ngày 26 sẽ lấy dữ liệu từ sheet 26 và đổ vào cột công của ngày 26 trong sheet BCC.


Còn hiện tại mình muốn sau khi đã tổng hợp công trong BCC xong, mình update tiếp thông tin ngày nghỉ dựa vào sheet N. Cột lý do nghỉ sẽ tự động điền vào cột WD của ngày công tương ứng. Trong code GPE mình sửa code của anh Bate từ If Ws.Name <> "BCC" thành If Ws.Name <> "BCC" And Ws.Name <> "N" vì nếu không sửa vậy thì code nó không chạy do mình thêm sheet N.

Mình biết chắc code sẽ không chạy bởi vì form nhập dữ liệu update nó khác hoàn toàn so với sheet công (26).
Nhấp chuột vào đây để mở rộng...

Bạn chạy Sub này thay Sub cũ xem kết quả thế nào.
PHP: 
Public Sub GPE()
Dim Dic As Object, Col As Object, Ws As Worksheet, Tem As String, Rws As Long
Dim sArr(), dArr(1 To 5000, 1 To 162), I As Long, J As Long, K As Long, C As Long, R As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Sheets("BCC")
    sArr = .Range("B6").Resize(, 162).Value
    For J = 1 To 162
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
End With
For Each Ws In Worksheets
    If Ws.Name <> "BCC" And Ws.Name <> "N" Then
        C = Col.Item(Val(Ws.Name))
        sArr = Ws.Range("C9", Ws.Range("C9").End(xlDown)).Resize(, 38).Value
        For I = 1 To UBound(sArr)
            Tem = sArr(I, 1)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add Tem, K
                dArr(K, 1) = sArr(I, 1)
            End If
            Rws = Dic.Item(Tem)
            dArr(Rws, C) = sArr(I, 33)
            dArr(Rws, C + 1) = sArr(I, 34):         dArr(Rws, C + 2) = sArr(I, 35)
            dArr(Rws, C + 3) = sArr(I, 36):         dArr(Rws, C + 4) = sArr(I, 38)
        Next I
    End If
Next Ws
    With Sheets("N")
        R = .Range("A65536").End(xlUp).Row
            If R > 3 Then
                sArr = .Range("A3:D" & R).Value
                For I = 2 To UBound(sArr)
                    Tem = sArr(I, 1)
                    Rws = Dic.Item(Tem)
                    C = Col.Item(Day(sArr(I, 4)))
                    dArr(Rws, C) = sArr(I, 3)
                Next I
            End If
    End With
Sheets("BCC").Range("B8").Resize(K, 162) = dArr
Set Dic = Nothing
Set Col = Nothing
End Sub
Bấm nút 1 lần là xong, không cần nút thứ hai.
 
Lần chỉnh sửa cuối:
Upvote 0
PHP: 
Public Sub GPE()
Dim Dic As Object, Col As Object, Ws As Worksheet, Tem As String, Rws As Long
Dim sArr(), dArr(1 To 5000, 1 To 162), I As Long, J As Long, K As Long, C As Long, R As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Sheets("BCC")
    sArr = .Range("B6").Resize(, 162).Value
    For J = 1 To 162
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
End With
For Each Ws In Worksheets
    If Ws.Name <> "BCC" And Ws.Name <> "N" Then
        C = Col.Item(Val(Ws.Name))
        sArr = Ws.Range("C9", Ws.Range("C9").End(xlDown)).Resize(, 38).Value
        For I = 1 To UBound(sArr)
            Tem = sArr(I, 1)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add Tem, K
                dArr(K, 1) = sArr(I, 1)
            End If
            Rws = Dic.Item(Tem)
            dArr(Rws, C) = sArr(I, 33)
            dArr(Rws, C + 1) = sArr(I, 34):         dArr(Rws, C + 2) = sArr(I, 35)
            dArr(Rws, C + 3) = sArr(I, 36):         dArr(Rws, C + 4) = sArr(I, 38)
        Next I
    End If
Next Ws
    With Sheets("N")
        R = .Range("A65536").End(xlUp).Row
            If R > 3 Then
                sArr = .Range("A3:D" & R).Value
                For I = 2 To UBound(sArr)
                    Tem = sArr(I, 1)
                    Rws = Dic.Item(Tem)
                    C = Col.Item(Day(sArr(I, 4)))
                    dArr(Rws, C) = sArr(I, 3)
                Next I
            End If
    End With
Sheets("BCC").Range("B8").Resize(K, 162) = dArr
Set Dic = Nothing
Set Col = Nothing
End Sub

Code chạy đã đúng như em mong muốn anh ạ, tuy nhiên vì một số lý do trong công việc nên phiền anh có thể chia nhiệm vụ đó ra làm hai lệnh cho em được không? Một lần nữa em chân thành cảm ơn anh, mong rằng có dịp được trò chuyện trực tiếp với anh!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
tueyennhi đã viết:
..............................
Code chạy đã đúng như em mong muốn anh ạ, tuy nhiên vì một số lý do trong công việc nên phiền anh có thể chia nhiệm vụ đó ra làm hai lệnh cho em được không? Một lần nữa em chân thành cảm ơn anh, mong rằng có dịp được trò chuyện trực tiếp với anh!
Nhấp chuột vào đây để mở rộng...
Bạn xem lại File và kiểm tra kết quả nhé.
 

File đính kèm

Upvote 0
Anh Bate ơi cho em hỏi trường hợp em muốn lấy cả giá trị tên nhân viên thì làm thế nào ạ? Vì em thấy key item gì ấy nó chỉ dựa vào ngày.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

C
Fix lỗi Application.InputBox Type:=8 (1 người xem)
    • Cười
Trả lời
23
Đọc
566
ptm0412
ptm0412
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi (1 người xem)
Trả lời
5
Đọc
65
phongvanvu
P
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
39
Đọc
12K
ongke0711
ongke0711
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
55
Đọc
22K
Gà Con yêu VBA
Gà Con yêu VBA
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
165
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
113
ptm0412
ptm0412
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
5
Đọc
375
SA_DQ
SA_DQ
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
290
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
262
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (2 người xem)
    • Thích
Trả lời
0
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11 (1 người xem)
    • Thích
    • Yêu thích
Trả lời
1
Đọc
114
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
326
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
683
nghiabros
N
L
Nhờ hỗ trợ tìm hàm excel trả về giá trị
Trả lời
4
Đọc
122
lechuong174
L
SA_DQ
Copilot & giúp hỗ trợ nhập các ký tự đặt biệt
    • Thích
Trả lời
0
Đọc
87
SA_DQ
SA_DQ
GPE-Trợ Lý
[GPE20] BIỂU ĐỒ CHUYÊN NGHIỆP: PHÁ VỠ GIỚI HẠN 2 TRỤC CỦA EXCEL
    • Thích
    • Yêu thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
hadu8889
EXCEL TỰ ĐỘNG ĐÓNG KHI SỬA TEXT Ở TRÊN USERFORM
Trả lời
10
Đọc
253
LOGANWover
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (7 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
565
Đọc
78K
lacmatquan
L
H
Lấy giá trị format trong ô của excel
Trả lời
2
Đọc
175
LOGANWover
L
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom