Chuyên mục xử lý, gỡ rối code VBA

Liên hệ QC
Status
Không mở trả lời sau này.

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,918
Nhờ các anh chị chỉnh sửa giúp code.

1. Nhờ anh chị chỉnh code khi "phân tích vật tư" thì tại ô G9 khi click sẽ là =1.03*200 chứ không phải là 206. giống như cột D13 tại sheet CSDL DM

2. Nhờ a thêm code thêm đơn vị vật liệu tại cột E, Hiện tại cột E chỉ hiện đơn vị cho hàng đầu thôi.
 

File đính kèm

  • hoi vba.xls
    3 MB · Đọc: 9
Upvote 0
Mọi người xem giúp em code trong Module Tong_hop_cong này sai ở đâu mà không chạy

PHP:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant, dArr(1 To 10000, 1 To 40)
Set Dic = CreateObject("Scripting.Dictionary")

Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With

With Sheets("Tong hop cong")
    If CStr(.Range("C7")) <> "" Then
        .Range("C8:BP7000").ClearContents
    End If
    sArr = .Range("B6").Resize(, 34).Value
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    For I = 2 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty Then
            Dic.Item(sArr(I, 1)) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
             Tem=sarr(I,1)
            If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then
                If Dic.exists(Tem) Then
                    K = K + 1
                    dArr(K, 1) = 1
                    dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2)
                End If
                Rws = Dic.Item(Tem)
                dArr(Rws, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B8").Resize(K, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Nguyên tắc là từ list ID cột B trong sheet Tong hop cong, tổng hợp toàn bộ công của các ngày sheet và add vào ngày tương ứng. Ví dụ em có ID 11111, em rà soát các ngày công 26 27 và 28, tại cột R của các sheet này nếu lớn hơn không thì add vào cột ngày tương ứng của sheet Tong hop cong. Từ bài lần trước của bạn hkphuong giúp đỡ cứ tưởng là đã hiểu sơ sơ về Dic rồi vậy mà không hiểu sao lại sai :(
 

File đính kèm

  • Bios 11 - Copy.xlsb
    739.1 KB · Đọc: 13
Lần chỉnh sửa cuối:
Upvote 0
Mọi người xem giúp em code trong Module Tong_hop_cong này sai ở đâu mà không chạy

PHP:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant, dArr(1 To 10000, 1 To 40)
Set Dic = CreateObject("Scripting.Dictionary")

Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With

With Sheets("Tong hop cong")
    If CStr(.Range("C7")) <> "" Then
        .Range("C8:BP7000").ClearContents
    End If
    sArr = .Range("B6").Resize(, 34).Value
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    For I = 2 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty Then
            Dic.Item(sArr(I, 1)) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then
                If Dic.exists(sArr(I, 1)) Then
                    K = K + 1
                    dArr(K, 1) = 1
                    dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2)
                End If
                Rws = Dic.Item(Tem)
                dArr(Rws, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B8").Resize(K, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Nguyên tắc là từ list ID cột B trong sheet Tong hop cong, tổng hợp toàn bộ công của các ngày sheet và add vào ngày tương ứng. Ví dụ em có ID 11111, em rà soát các ngày công 26 27 và 28, tại cột R của các sheet này nếu lớn hơn không thì add vào cột ngày tương ứng của sheet Tong hop cong. Từ bài lần trước của bạn hkphuong giúp đỡ cứ tưởng là đã hiểu sơ sơ về Dic rồi vậy mà không hiểu sao lại sai :(
Code của bạn có đoạn: Rws = Dic.Item(Tem)
Biến Tem tính toán từ đâu ra vậy?
 
Upvote 0
Code của bạn có đoạn: Rws = Dic.Item(Tem)
Biến Tem tính toán từ đâu ra vậy?
Từ đoạn này
For I = 1 To UBound(sArr, 1)
If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then

Em đặt Tem như vậy thầy ạ.
Tem = sarr(i,1)
For I = 1 To UBound(sArr, 1)

Cả đoạn sẽ là như sau
PHP:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant, dArr(1 To 10000, 1 To 40)
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
    sArr = .Range("B6").Resize(100, 34).Value
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 2 To UBound(sArr, 1)
        Dic.Item(sArr(I, 1)) = I
    Next
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1)
            If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then
                If Dic.exists(Tem) Then
                    K = K + 1
                    dArr(K, 1) = sArr(I, 1)
                    dArr(K, 2) = sArr(I, 2)
                    dArr(K, 3) = sArr(I, 3)
                End If
                Rws = Dic.Item(Tem)
                dArr(Rws, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(K, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
sArr = Range("A6").CurrentRegion
R = UBound(sArr, 1)
C = UBound(sArr, 2)
ReDim tArr(2 To R, 1 To 5)
For I = 2 To R
    For J = 5 To C
        If sArr(1, J) <= sArr(I, 1) Then
            If IsNumeric(sArr(I, J)) Then
                tArr(I, 1) = tArr(I, 1) + sArr(I, J)
            ElseIf sArr(I, J) Like "1D" Then
                tArr(I, 2) = Application.WorksheetFunction.Sum(tArr(I, 2) + Left(sArr(I, J), InStr(1, sArr(I, J), "D") - 1))
            End If
        ElseIf sArr(1, J) > sArr(I, 1) Then
            If IsNumeric(sArr(I, J)) Then
                tArr(I, 3) = tArr(I, 3) + sArr(I, J)
            ElseIf sArr(I, J) Like "1D" Then
                tArr(I, 4) = Application.WorksheetFunction.Sum(tArr(I, 4) + Left(sArr(I, J), InStr(1, sArr(I, J), "D") - 1))
            End If
        End If
    Next J
    tArr(I, 5) = tArr(I, 1) + tArr(I, 2) + tArr(I, 3) + tArr(I, 4)
Next I
Sheets("Tong hop cong").Range("AK7").Resize(I - 2, 5) = tArr
Sheets("Tong hop cong").Range("A6").CurrentRegion.Borders.LineStyle = xlContinuous
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Em bị báo lỗi dòng
dArr(Rws, C) = sArr(I, 17)
 
Lần chỉnh sửa cuối:
Upvote 0
Mọi người xem giúp em code trong Module Tong_hop_cong này sai ở đâu mà không chạy

PHP:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant, dArr(1 To 10000, 1 To 40)
Set Dic = CreateObject("Scripting.Dictionary")

Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With

With Sheets("Tong hop cong")
    If CStr(.Range("C7")) <> "" Then
        .Range("C8:BP7000").ClearContents
    End If
    sArr = .Range("B6").Resize(, 34).Value
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    For I = 2 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty Then
            Dic.Item(sArr(I, 1)) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
             Tem=sarr(I,1)
            If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then
                If Dic.exists(Tem) Then
                    K = K + 1
                    dArr(K, 1) = 1
                    dArr(K, 2) = sArr(I, 1)
                    dArr(K, 3) = sArr(I, 2)
                End If
                Rws = Dic.Item(Tem)
                dArr(Rws, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B8").Resize(K, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Nguyên tắc là từ list ID cột B trong sheet Tong hop cong, tổng hợp toàn bộ công của các ngày sheet và add vào ngày tương ứng. Ví dụ em có ID 11111, em rà soát các ngày công 26 27 và 28, tại cột R của các sheet này nếu lớn hơn không thì add vào cột ngày tương ứng của sheet Tong hop cong. Từ bài lần trước của bạn hkphuong giúp đỡ cứ tưởng là đã hiểu sơ sơ về Dic rồi vậy mà không hiểu sao lại sai :(

sArr = .Range("B6").Resize(, 34).Value chỉ có 1 dòng thôi
 
Upvote 0
Sub Button16_click()
Dim printFrom As Integer, printTo As Integer, I As Integer
Dim Ra As Range
'================================

printFrom = Sheets("PYC").Range("AG3").Value 'STT bat dau
printTo = Sheets("PYC").Range("AG4").Value 'STT ket thuc

'================================

For I = printFrom To printTo
Sheets("PYC").Range("AG1").Value = I
Sheets("PYC").PrintOut preview:=False
Next I
End Sub


Nhờ các bác chỉnh sửa giùm em đoạn code này với ak. Hiện tại em tạo nút in trên sheet PYC luôn. Em muốn tạo 1 form in dữ liệu, khi nhấn Button16_click thì sẽ hiện form in và in dữ liệu ở sheet PYC. Em làm đủ cách mà không ra. Em có đính kèm Form in dữ liệu.
 

File đính kèm

  • IN PYC.jpg
    IN PYC.jpg
    14.2 KB · Đọc: 3
Upvote 0
Sub Button16_click()
Dim printFrom As Integer, printTo As Integer, I As Integer
Dim Ra As Range
'================================

printFrom = Sheets("PYC").Range("AG3").Value 'STT bat dau
printTo = Sheets("PYC").Range("AG4").Value 'STT ket thuc

'================================

For I = printFrom To printTo
Sheets("PYC").Range("AG1").Value = I
Sheets("PYC").PrintOut preview:=False
Next I
End Sub


Nhờ các bác chỉnh sửa giùm em đoạn code này với ak. Hiện tại em tạo nút in trên sheet PYC luôn. Em muốn tạo 1 form in dữ liệu, khi nhấn Button16_click thì sẽ hiện form in và in dữ liệu ở sheet PYC. Em làm đủ cách mà không ra. Em có đính kèm Form in dữ liệu.
Thay vì đính kèm cái ảnh kia bạn đính kèm File thì đã nhận hàng chục câu trả lời rồi
 
Upvote 0
Em sửa lại code bài #1248 rồi mà vẫn không được. Vẫn báo lỗi như vậy. Không biết còn sai ở đâu.
Bạn cần gì nêu cụ thể, viết mới tiện hơn
Cột ID chỉ lấy 8 dòng qui định trước hay lấy hết ở các sheet khác, các sheet ID là giống hay khác?
 
Upvote 0
Bạn cần gì nêu cụ thể, viết mới tiện hơn
Cột ID chỉ lấy 8 dòng qui định trước hay lấy hết ở các sheet khác, các sheet ID là giống hay khác?
- Em chỉ lấy 8 dòng quy định trước. Từ list ID này sẽ lấy dữ liệu ở cột R của các sheet 26 27 28 nếu có. (26 27 28 là dữ liệu chấm công của lần lượt các ngày 26 27 28). ID có thể có ở sheet này không có ở sheet kia hoặc đều có ở 3 sheet nhưng chắc chắn tối thiểu sẽ có ở 1 trong 3 sheet 26 27 28
 
Upvote 0
- Em chỉ lấy 8 dòng quy định trước. Từ list ID này sẽ lấy dữ liệu ở cột R của các sheet 26 27 28 nếu có. (26 27 28 là dữ liệu chấm công của lần lượt các ngày 26 27 28). ID có thể có ở sheet này không có ở sheet kia hoặc đều có ở 3 sheet nhưng chắc chắn tối thiểu sẽ có ở 1 trong 3 sheet 26 27 28
Mã:
Private Sub Tong_cong()
Dim Dic As Object, ws As Worksheet, Tem As String
Dim ngayd As Long, I As Long, K As Long, C As Long
Dim sArr As Variant, dArr As Variant
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")

With Sheets("Tong hop cong")
    ngayd = Day(.Range("E6").Value)
    If CStr(.Range("C7")) <> "" Then
        .Range("C7:BP7000").ClearContents
    End If
    sArr = .Range("B7", Range("B65000").End(xlUp)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 31)
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty Then
            Dic.Item(CStr(sArr(I, 1))) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = ((Val(ws.Name) - ngayd) Mod 31) + 4
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 17) > 0 Then
                Tem = sArr(I, 1)
                If Dic.exists(CStr(Tem)) Then
                    K = Dic.Item(Tem)
                    dArr(K, 1) = Tem
                    dArr(K, 2) = sArr(I, 2)
                    dArr(K, 3) = sArr(I, 3)
                    dArr(K, C) = sArr(I, 17)
                End If
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Mã:
Private Sub Tong_cong()
Dim Dic As Object, ws As Worksheet, Tem As String
Dim ngayd As Long, I As Long, K As Long, C As Long
Dim sArr As Variant, dArr As Variant
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")

With Sheets("Tong hop cong")
    ngayd = Day(.Range("E6").Value)
    If CStr(.Range("C7")) <> "" Then
        .Range("C7:BP7000").ClearContents
    End If
    sArr = .Range("B7", Range("B65000").End(xlUp)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 31)
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> Empty Then
            Dic.Item(CStr(sArr(I, 1))) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = ((Val(ws.Name) - ngayd) Mod 31) + 4
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 17) > 0 Then
                Tem = sArr(I, 1)
                If Dic.exists(CStr(Tem)) Then
                    K = Dic.Item(Tem)
                    dArr(K, 1) = Tem
                    dArr(K, 2) = sArr(I, 2)
                    dArr(K, 3) = sArr(I, 3)
                    dArr(K, C) = sArr(I, 17)
                End If
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
Tại ngày 23 24 25 xuất hiện #N/A anh ơi.
 
Lần chỉnh sửa cuối:
Upvote 0
Khi chạy nó báo Type mismatch ở dòng If sArr(I, 1) <> Empty Then
Ngoài ra cái cách viết Col ban đầu khá hay có cách nào giữ nguyên cách đó mà vẫn giải quyết được bài toán này không anh? Nếu không được cũng không sao miễn là giải quyết được vấn đề này của e
Type mismatch ở dòng If sArr(I, 1) <> Empty cũng hơi lạ bạn có đổi khai báo Dim không? thử If Len(sArr(I, 1)) > 0 Then
Dùng Dic để tính col chắc ăn hơn, bạn tự thêm vào để thế dòng lệnh dưới xem sau
C = ((Val(ws.Name) - ngayd) Mod 31) + 4
 
Upvote 0
Type mismatch ở dòng If sArr(I, 1) <> Empty cũng hơi lạ bạn có đổi khai báo Dim không? thử If Len(sArr(I, 1)) > 0 Then
Dùng Dic để tính col chắc ăn hơn, bạn tự thêm vào để thế dòng lệnh dưới xem sau
C = ((Val(ws.Name) - ngayd) Mod 31) + 4

Chắc ban đầu code mới dán vào chưa được lưu nên chạy lỗi, chạy lại đã không còn lỗi nữa nhưng cột 23 24 25 xuất hiện giá trị #N/A (3x8 = 24 giá trị #N/A)
 
Upvote 0
Chắc ban đầu code mới dán vào chưa được lưu nên chạy lỗi, chạy lại đã không còn lỗi nữa nhưng cột 23 24 25 xuất hiện giá trị #N/A (3x8 = 24 giá trị #N/A)
Mình quên nhìn các cột cuối
Mã:
Private Sub Tong_cong()
Dim Dic As Object, ws As Worksheet, Tem As String
Dim ngayd As Long, I As Long, K As Long, C As Long
Dim sArr As Variant, dArr As Variant
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")

With Sheets("Tong hop cong")
    ngayd = Day(.Range("E6").Value)
    If CStr(.Range("C7")) <> "" Then
        .Range("C7:BP7000").ClearContents
    End If
    sArr = .Range("B7", .Range("B65000").End(xlUp)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 34)
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) > 0 Then
            Dic.Item(CStr(sArr(I, 1))) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = ((Val(ws.Name) + 31 - ngayd) Mod 31) + 4
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 17) > 0 Then
                Tem = sArr(I, 1)
                If Dic.exists(CStr(Tem)) Then
                    K = Dic.Item(Tem)
                    dArr(K, 1) = Tem
                    dArr(K, 2) = sArr(I, 2)
                    dArr(K, 3) = sArr(I, 3)
                    dArr(K, C) = sArr(I, 17)
                End If
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Mình quên nhìn các cột cuối
Mã:
Private Sub Tong_cong()
Dim Dic As Object, ws As Worksheet, Tem As String
Dim ngayd As Long, I As Long, K As Long, C As Long
Dim sArr As Variant, dArr As Variant
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")

With Sheets("Tong hop cong")
    ngayd = Day(.Range("E6").Value)
    If CStr(.Range("C7")) <> "" Then
        .Range("C7:BP7000").ClearContents
    End If
    sArr = .Range("B7", .Range("B65000").End(xlUp)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 34)
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) > 0 Then
            Dic.Item(CStr(sArr(I, 1))) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = ((Val(ws.Name) + 31 - ngayd) Mod 31) + 4
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 17) > 0 Then
                Tem = sArr(I, 1)
                If Dic.exists(CStr(Tem)) Then
                    K = Dic.Item(Tem)
                    dArr(K, 1) = Tem
                    dArr(K, 2) = sArr(I, 2)
                    dArr(K, 3) = sArr(I, 3)
                    dArr(K, C) = sArr(I, 17)
                End If
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
Từ code của bạn mình viết theo ý giữ nguyên Col như sau:
PHP:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant
Set Dic = CreateObject("Scripting.Dictionary")

Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
    If CStr(.Range("C7")) <> "" Then
        .Range("C8:BP7000").ClearContents
    End If
    sArr = .Range("B6", .Range("B65000").End(xlUp)).Resize(, 34).Value
    ReDim dArr(2 To UBound(sArr, 1), 1 To 34)
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    For I = 2 To UBound(sArr, 1)
        If Len(sArr(I, 1)) > 0 Then
            Dic.Item(CStr(sArr(I, 1))) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1)
            If Dic.exists(CStr(Tem)) Then
                K = Dic.Item(Tem)
                dArr(K, 1) = Tem
                dArr(K, 2) = sArr(I, 2)
                dArr(K, 3) = sArr(I, 3)
                dArr(K, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr) - 1, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Cái chỗ:
ReDim dArr(2 To UBound(sArr, 1), 1 To 34)
em viết vậy có ổn không vì nếu em viết là
ReDim dArr(1 To UBound(sArr, 1), 1 To 34)
thì khi chạy kết quả xuất hiện ô trống đầu tiên ở B7. Em sửa lại như vậy thì không bị nữa.

Và chỗ này cũng phải viết lại là
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr) - 1, 34) = dArr
Nếu không thì dòng cuối luôn là các giá trị #N/A
 
Lần chỉnh sửa cuối:
Upvote 0
Xin nhờ các anh chị sửa giúp đoạn code trong file:
Khi lọc với điều kiện tại sheet AB ở ô J3 = 1 nhưng kết quả lọc chưa chính xác ở cột F ( thay vì chỉ lọc các dòng có điều kiện là 1 ở cột O sheet Data )
Xin cảm ơn.
 

File đính kèm

  • LoiTumLum1.rar
    18.7 KB · Đọc: 6
Lần chỉnh sửa cuối:
Upvote 0
Từ code của bạn mình viết theo ý giữ nguyên Col như sau:
PHP:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant
Set Dic = CreateObject("Scripting.Dictionary")

Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
    If CStr(.Range("C7")) <> "" Then
        .Range("C8:BP7000").ClearContents
    End If
    sArr = .Range("B6", .Range("B65000").End(xlUp)).Resize(, 34).Value
    ReDim dArr(2 To UBound(sArr, 1), 1 To 34)
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    For I = 2 To UBound(sArr, 1)
        If Len(sArr(I, 1)) > 0 Then
            Dic.Item(CStr(sArr(I, 1))) = I
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1)
            If Dic.exists(CStr(Tem)) Then
                K = Dic.Item(Tem)
                dArr(K, 1) = Tem
                dArr(K, 2) = sArr(I, 2)
                dArr(K, 3) = sArr(I, 3)
                dArr(K, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr) - 1, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Cái chỗ:
ReDim dArr(2 To UBound(sArr, 1), 1 To 34)
em viết vậy có ổn không vì nếu em viết là
ReDim dArr(1 To UBound(sArr, 1), 1 To 34)
thì khi chạy kết quả xuất hiện ô trống đầu tiên ở B7. Em sửa lại như vậy thì không bị nữa.

Và chỗ này cũng phải viết lại là
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr) - 1, 34) = dArr
Nếu không thì dòng cuối luôn là các giá trị #N/A
Chỉnh lại dArr cho hợp lý hơn
sArr = .Range("B6", .Range("B65000").End(xlUp)).Resize(, 34).Value
ReDim dArr(1 To UBound(sArr, 1) - 1, 1 To 34)

Dic.Item(CStr(sArr(I, 1))) = I - 1

Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Mã:
Private Sub Tong_cong1()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant
Set Dic = CreateObject("Scripting.Dictionary")

Set Col = CreateObject("Scripting.Dictionary")
With Application
    .CalculateBeforeSave = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
    If CStr(.Range("C7")) <> "" Then
        .Range("C8:BP7000").ClearContents
    End If
    sArr = .Range("B6", .Range("B65000").End(xlUp)).Resize(, 34).Value
    ReDim dArr(1 To UBound(sArr, 1) - 1, 1 To 34)
    For J = 4 To 34
        If sArr(1, J) <> Empty Then
            If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
        End If
    Next J
    For I = 2 To UBound(sArr, 1)
        If Len(sArr(I, 1)) > 0 Then
            Dic.Item(CStr(sArr(I, 1))) = I - 1
        End If
    Next I
End With
For Each ws In Worksheets
    If IsNumeric(ws.Name) Then
        C = Col.Item(Val(ws.Name))
        sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1)
            If Dic.exists(CStr(Tem)) Then
                K = Dic.Item(Tem)
                dArr(K, 1) = Tem
                dArr(K, 2) = sArr(I, 2)
                dArr(K, 3) = sArr(I, 3)
                dArr(K, C) = sArr(I, 17)
            End If
        Next I
    End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
    .CalculateBeforeSave = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .CalculateBeforeSave = True
    .EnableCancelKey = xlInterrupt
End With
End Sub
 
Upvote 0
Xin nhờ các anh chị sửa giúp đoạn code trong file:
Khi lọc với điều kiện tại sheet AB ở ô J3 = 1 nhưng kết quả lọc chưa chính xác ở cột F ( thay vì chỉ lọc các dòng có điều kiện là 1 ở cột O sheet Data )
Xin cảm ơn.
 

File đính kèm

  • LoiTumLum2.rar
    19 KB · Đọc: 5
Upvote 0
Status
Không mở trả lời sau này.
Web KT
Back
Top Bottom