Chuyên mục xử lý, gỡ rối code VBA (1 người xem)

ndu96081631 · 24/9/13

Topic Những câu hỏi về code, xin giải thích các code... đã quá dài nên mình đóng nó lại và mở topic khác
Tất cả những bài viết liên quan đến việc nhờ giải thích, xử lý và gỡ rối code VBA, các bạn vui lòng đăng tại đây!
Cảm ơn

HieuCD · 13/11/17

tueyennhi đã viết:
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?

tueyennhi · 13/11/17

HieuCD đã viết:
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

HieuCD · 13/11/17

tueyennhi đã viết:
- 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

tueyennhi · 13/11/17

HieuCD đã viết:

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.

HieuCD · 13/11/17

tueyennhi đã viết:
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

tueyennhi · 13/11/17

HieuCD đã viết:
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)

HieuCD · 13/11/17

tueyennhi đã viết:
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

tueyennhi · 14/11/17

HieuCD đã viết:

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

huongmuine · 14/11/17

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.

HieuCD · 14/11/17

tueyennhi đã viết:

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

Ba Tê · 14/11/17

huongmuine đã viết:
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.

huongmuine · 14/11/17

Xin cảm ơn Thầy nhiều ạ.

tueyennhi · 14/11/17

HieuCD đã viết:

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

- Cái chỗ ReDim dArr(1 To UBound(sArr, 1) - 1, 1 To 34)
Chắc là để loại bỏ N/A mà không phải trừ 1 phần tử khi gán mảng dArr phải không anh?

- Vậy thì đoạn này: Dic.Item(CStr(sArr(I, 1))) = I - 1 tại sao phải trừ 1? Code của em không trừ 1 mà nó vẫn chạy đúng nhưng của anh nếu không trừ 1 thì sẽ báo lỗi ngay.

HieuCD · 14/11/17

tueyennhi đã viết:
- Cái chỗ ReDim dArr(1 To UBound(sArr, 1) - 1, 1 To 34)
Chắc là để loại bỏ N/A mà không phải trừ 1 phần tử khi gán mảng dArr phải không anh?

- Vậy thì đoạn này: Dic.Item(CStr(sArr(I, 1))) = I - 1 tại sao phải trừ 1? Code của em không trừ 1 mà nó vẫn chạy đúng nhưng của anh nếu không trừ 1 thì sẽ báo lỗi ngay.

sArr lấy từ dòng 6, dArr lấy từ dòng 7,nên số dòng của dArr ít hơn sArr 1 dòng, nên khai báo dArr:
ReDim dArr(1 To UBound(sArr, 1) - 1, 1 To 34)

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
Vòng lặp bắt đầu i=2, dArr bắt đầu từ 1, nên I-1 là thứ tự dòng của dArr

Để tường minh hơn và nhẹ code, bạn chỉnh code lại như sau

Mã:

With Sheets("Tong hop cong")
   If CStr(.Range("C7")) <> "" Then
       .Range("C8:BP7000").ClearContents
   End If
   sArr = .Range("B6").Resize(, 34).Value 'lay cot ngay
   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
   sArr = .Range("B7", .Range("B65000").End(xlUp)).Value 'lay dong
   ReDim dArr(1 To UBound(sArr, 1), 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

duytmd · 15/11/17

Nhờ các bác viết giúp mình 1 code vba.
1. khi click vào nút THVT từ sheet xuatDL thì vật tư ( VL, NC, M) được lọc và xuất sang sheet THVT như ví dụ ở sheet THVT.
A) Vật liệu:
xi măng
.........
B)Nhán công
Nhân công
C)Máy thi công
M:...........

PacificPR · 15/11/17

duytmd đã viết:
Nhờ các bác viết giúp mình 1 code vba.
1. khi click vào nút THVT từ sheet xuatDL thì vật tư ( VL, NC, M) được lọc và xuất sang sheet THVT như ví dụ ở sheet THVT.
A) Vật liệu:
xi măng
.........
B)Nhán công
Nhân công
C)Máy thi công
M:...........

Bạn chạy Sub này thử

PHP:

Sub Tonghopvattu()
Application.ScreenUpdating = False
    Dim Dic As Object, Tem As String
    Dim sArr(), dArr(), tArr(), Er As Long
    Dim I As Long, J As Long, N As Long, K As Long, LaMa As Long, Stt As Long, Rws As Long
Set Dic = CreateObject("scripting.Dictionary")
With Sheets("xuatDL")
    sArr = .Range("C7", .Range("C65536").End(3)).Resize(, 5).Value
    tArr = .Range("L1:N1").Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With Sheets("THVT")
    With .Range("A6:I1000")
        .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = 0: .Font.Bold = False
    End With
    For N = 1 To 3
        Stt = 0:        LaMa = LaMa + 1:        K = K + 1
        dArr(K, 1) = ChrW(LaMa + 64): dArr(K, 2) = tArr(1, N)
        .Range("A" & K + 5).Resize(, 9).Interior.ColorIndex = 20
        .Range("A" & K + 5).Resize(, 9).Font.Bold = True
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 1) <> Empty Then
                If Left(sArr(I, 1), 1) = Left(tArr(1, N), 1) Then
                    Tem = sArr(I, 1)
                    If Not Dic.Exists(Tem) Then
                        K = K + 1: Stt = Stt + 1
                        Dic.Add Tem, K
                        dArr(K, 1) = Stt:           dArr(K, 2) = sArr(I, 1)
                        dArr(K, 3) = sArr(I, 2):    dArr(K, 4) = sArr(I, 3)
                        dArr(K, 5) = sArr(I, 5)
                    Else
                        Rws = Dic.Item(Tem): dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 5)
                    End If
                End If
            End If
        Next I
    Next N
    .Range("A6").Resize(K, 5) = dArr:
    .Range("A6").Resize(K, 9).Borders.LineStyle = 1
    If Not IsNumeric(.Range("A65536").End(3)) Then .Range("A65536").End(3).EntireRow.Delete
    Er = .Range("A65536").End(3).Row
    For I = Er To 6 Step -1
        If Not IsNumeric(.Range("A" & I)) Then
            .Range("B" & I + 1 & ":I" & Er).Sort Key1:=.Range("C" & I + 1)
            Er = I - 1
        End If
    Next I
End With
Set Dic = Nothing
End Sub

duytmd · 15/11/17

PacificPR đã viết:

Bạn chạy Sub này thử

PHP:

Sub Tonghopvattu()
Application.ScreenUpdating = False
    Dim Dic As Object, Tem As String
    Dim sArr(), dArr(), tArr(), Er As Long
    Dim I As Long, J As Long, N As Long, K As Long, LaMa As Long, Stt As Long, Rws As Long
Set Dic = CreateObject("scripting.Dictionary")
With Sheets("xuatDL")
    sArr = .Range("C7", .Range("C65536").End(3)).Resize(, 5).Value
    tArr = .Range("L1:N1").Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With Sheets("THVT")
    With .Range("A6:I1000")
        .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = 0: .Font.Bold = False
    End With
    For N = 1 To 3
        Stt = 0:        LaMa = LaMa + 1:        K = K + 1
        dArr(K, 1) = ChrW(LaMa + 64): dArr(K, 2) = tArr(1, N)
        .Range("A" & K + 5).Resize(, 9).Interior.ColorIndex = 20
        .Range("A" & K + 5).Resize(, 9).Font.Bold = True
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 1) <> Empty Then
                If Left(sArr(I, 1), 1) = Left(tArr(1, N), 1) Then
                    Tem = sArr(I, 1)
                    If Not Dic.Exists(Tem) Then
                        K = K + 1: Stt = Stt + 1
                        Dic.Add Tem, K
                        dArr(K, 1) = Stt:           dArr(K, 2) = sArr(I, 1)
                        dArr(K, 3) = sArr(I, 2):    dArr(K, 4) = sArr(I, 3)
                        dArr(K, 5) = sArr(I, 5)
                    Else
                        Rws = Dic.Item(Tem): dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 5)
                    End If
                End If
            End If
        Next I
    Next N
    .Range("A6").Resize(K, 5) = dArr:
    .Range("A6").Resize(K, 9).Borders.LineStyle = 1
    If Not IsNumeric(.Range("A65536").End(3)) Then .Range("A65536").End(3).EntireRow.Delete
    Er = .Range("A65536").End(3).Row
    For I = Er To 6 Step -1
        If Not IsNumeric(.Range("A" & I)) Then
            .Range("B" & I + 1 & ":I" & Er).Sort Key1:=.Range("C" & I + 1)
            Er = I - 1
        End If
    Next I
End With
Set Dic = Nothing
End Sub

Cám ơn chị rất nhiều. chị có thể chỉnh sửa bài #1245 giúp e được không?
Chuyên mục xử lý, gỡ rối code VBA

duytmd · 16/11/17

PacificPR đã viết:

Bạn chạy Sub này thử

PHP:

Sub Tonghopvattu()
Application.ScreenUpdating = False
    Dim Dic As Object, Tem As String
    Dim sArr(), dArr(), tArr(), Er As Long
    Dim I As Long, J As Long, N As Long, K As Long, LaMa As Long, Stt As Long, Rws As Long
Set Dic = CreateObject("scripting.Dictionary")
With Sheets("xuatDL")
    sArr = .Range("C7", .Range("C65536").End(3)).Resize(, 5).Value
    tArr = .Range("L1:N1").Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With Sheets("THVT")
    With .Range("A6:I1000")
        .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = 0: .Font.Bold = False
    End With
    For N = 1 To 3
        Stt = 0:        LaMa = LaMa + 1:        K = K + 1
        dArr(K, 1) = ChrW(LaMa + 64): dArr(K, 2) = tArr(1, N)
        .Range("A" & K + 5).Resize(, 9).Interior.ColorIndex = 20
        .Range("A" & K + 5).Resize(, 9).Font.Bold = True
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 1) <> Empty Then
                If Left(sArr(I, 1), 1) = Left(tArr(1, N), 1) Then
                    Tem = sArr(I, 1)
                    If Not Dic.Exists(Tem) Then
                        K = K + 1: Stt = Stt + 1
                        Dic.Add Tem, K
                        dArr(K, 1) = Stt:           dArr(K, 2) = sArr(I, 1)
                        dArr(K, 3) = sArr(I, 2):    dArr(K, 4) = sArr(I, 3)
                        dArr(K, 5) = sArr(I, 5)
                    Else
                        Rws = Dic.Item(Tem): dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 5)
                    End If
                End If
            End If
        Next I
    Next N
    .Range("A6").Resize(K, 5) = dArr:
    .Range("A6").Resize(K, 9).Borders.LineStyle = 1
    If Not IsNumeric(.Range("A65536").End(3)) Then .Range("A65536").End(3).EntireRow.Delete
    Er = .Range("A65536").End(3).Row
    For I = Er To 6 Step -1
        If Not IsNumeric(.Range("A" & I)) Then
            .Range("B" & I + 1 & ":I" & Er).Sort Key1:=.Range("C" & I + 1)
            Er = I - 1
        End If
    Next I
End With
Set Dic = Nothing
End Sub

Các bạn và bạn PacificPR giúp mình thêm code này nữa nhé!
1. khi click nút link thì cột H (đơn giá) của sheet xuatDL được kết nối từ sheet THVT, sau đó sum của VL, NC, máy sẽ được link sang sheet KHOILUONG
2. Từ sheet THVT bạn có thể xuất số liệu của phần vật liệu sang sheet VAT LIEU, mỗi vật liệu cách nhau 5 dòng. Thank!

PacificPR · 17/11/17

duytmd đã viết:
Các bạn và bạn PacificPR giúp mình thêm code này nữa nhé!
1. khi click nút link thì cột H (đơn giá) của sheet xuatDL được kết nối từ sheet THVT, sau đó sum của VL, NC, máy sẽ được link sang sheet KHOILUONG
2. Từ sheet THVT bạn có thể xuất số liệu của phần vật liệu sang sheet VAT LIEU, mỗi vật liệu cách nhau 5 dòng. Thank!

Hình như cái File này em đã gặp ở đâu trên diễn đàn mình roài thì phải. (Hình như bài của anh "Sơn thủ bạc")

duytmd · 17/11/17

duytmd đã viết:
Các bạn và bạn PacificPR giúp mình thêm code này nữa nhé!
1. khi click nút link thì cột H (đơn giá) của sheet xuatDL được kết nối từ sheet THVT, sau đó sum của VL, NC, máy sẽ được link sang sheet KHOILUONG
2. Từ sheet THVT bạn có thể xuất số liệu của phần vật liệu sang sheet VAT LIEU, mỗi vật liệu cách nhau 5 dòng. Thank!

có ai không, giúp mình với đi

Chuyên mục xử lý, gỡ rối code VBA (1 người xem)

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

Huyền thoại GPE

Chuyên gia GPE

Thành viên tích cực

Chuyên gia GPE

Thành viên tích cực

Chuyên gia GPE

Thành viên tích cực

Chuyên gia GPE

Thành viên tích cực

Thành viên GPE

File đính kèm

Chuyên gia GPE

Cạo Rồi Khỏi Gội

File đính kèm

Thành viên GPE

Thành viên tích cực

Chuyên gia GPE

Thành viên chính thức

File đính kèm

Thành viên mới

Thành viên chính thức

Thành viên chính thức

File đính kèm

Thành viên mới

Thành viên chính thức

Đếm ngược thời gian