Chuyên đề giải đáp những thắc mắc về code VBA (9 người xem)

maytinhvp01 · 31/7/13

Mình muốn nhờ giải thich câu lệnh " If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c) "
trong ví du:
Public Function LonNhat(Ran As Range)
Dim max As Double, v As Integer, d As Integer, c As Integer
max = Ran.Cells(1, 1)
For d = 1 To Ran.Rows.Count
For c = 1 To Ran.Columns.Count
If Ran.Cells(d, c) > max Then max = Ran.Cells(d, c)
Next c
Next d
v = Tim(max, Ran)
LonNhat = max
End Function
-------------------------------------------------------
[INFO1]Thông báo:
Vì topic này:
http://www.giaiphapexcel.com/forum/...ải-thích-các-code-đề-nghị-các-bạn-gửi-vào-đây
đã quá dài nên BQT đóng lại.
Nay tôi mở topic mới với cùng chủ đề: GIẢI THÍCH NHỮNG THẮC MẮC VỀ CODE
Các bạn nếu có nhu cầu giải thích code, vui lòng post tại đây nhé
NDU96081631
[/INFO1]

tueyennhi · 13/6/18

Ba Tê đã viết:
Đưa dữ liệu giống thật, giống những cái nếu, ... chứ tôi sao biết chỗ nào là "nếu ..."
Ý ban đầu đã không xác định, rồi nếu thì "tanh bành" cái code.

Vâng tại ban đầu em không đặt trường hợp hai nhà hoặc ba nhà báo đồng giá. Em gửi anh xem nhé

Ba Tê · 13/6/18

tueyennhi đã viết:
Vâng tại ban đầu em không đặt trường hợp hai nhà hoặc ba nhà báo đồng giá. Em gửi anh xem nhé

tueyennhi · 13/6/18

Hay quá, em không nghĩ vấn đề được giải quyết nhanh chóng và đơn giản vậy. Code của anh rất dễ áp dụng cho các tình huống khác. Cảm ơn anh nhiều nhé!

chisinhvnn · 14/6/18

VetMini đã viết:
1. Gồm 2 phần:
Phần thứ nhất thì rất dễ, chỉ cần đặt 1 lệnh sau ngay đầu Module:
Public arr
Phần thứ hai hơi rắc rối. Cần xác định rõ tầm vực sử dụng.

2. Nếu arr được Dim là mảng thì không thể được, nếu Dim là Variant thì được.

Cho mình hỏi thêm. Mình khai báo biến như thế nào để khi mình chọn một vùng dữ liệu thì vào mãng, thì dữ liệu đó vẫn tồn tại trong mãng dù mình tắt file đi. Dữ liệu chỉ thay đổi khi mình chọn lại dữ liệu.

♫ђöล♥ßล†♥†µ♫ · 14/6/18

chisinhvnn đã viết:
Cho mình hỏi thêm. Mình khai báo biến như thế nào để khi mình chọn một vùng dữ liệu thì vào mãng, thì dữ liệu đó vẫn tồn tại trong mãng dù mình tắt file đi. Dữ liệu chỉ thay đổi khi mình chọn lại dữ liệu.

Bạn thử đặt Define Name cho vùng dữ liệu rồi gán mảng bằng Name thử xem

chisinhvnn · 14/6/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Bạn thử đặt Define Name cho vùng dữ liệu rồi gán mảng bằng Name thử xem

Như vậy thì chưa đúng ý mình. Mục đích của mình là tạo mãng dữ liệu lấy từ một file bất kỳ. (dùng lệnh input để lấy dữ liệu đấy)

VetMini · 14/6/18

chisinhvnn đã viết:
Cho mình hỏi thêm. Mình khai báo biến như thế nào để khi mình chọn một vùng dữ liệu thì vào mãng, thì dữ liệu đó vẫn tồn tại trong mãng dù mình tắt file đi. Dữ liệu chỉ thay đổi khi mình chọn lại dữ liệu.

Biến thuộc về vùng nhớ của phần mềm. Khi tắt file thì phần mềm tắt theo. Vùng nhớ của phần mềm bị trả về cho hệ thống. Muốn giữ trị của biến lại thì phải chịu khó học qua các phương pháp giữ dữ liệu (persistent data)

ngokylanvnn12 · 14/6/18

Các bạn giúp mình với, mình mới nghiên cứu excel nên cũng còn gà, mình lập 1 cái userform gồm có:
+ 2 Nút nhấn : thêm và thêm mới.
+ 1 lisboxt mình dùng definame đưa vào listbox và đặt tên là "DSD" (ở phần rowsouce mình điền "DSD" mình chỉ biết dùng cách này thôi các bạn có cách khác hay hơn xin hướng dẫn dùm)
+ 4 textboxt: 1 cái là dùng để tìm kiếm dữ liệu nhanh từ listbox, 3 cái còn lại để thêm mới vào dữ liệu trong "DSD"
mình muốn viết code như sau:
sau khi add dữ liệu vào listboxt thì nhấn nút "THÊM" dữ liệu trên listbox sẽ nạp nhu sau:
+Cột "DANH MỤC" trong listbox sẽ nộp vào cột B phía dưới hàng có tên "SCOPE OF WORK" trong sheet "ELECTRICAL SYSTEM".
+Cột "VẬT TƯ" trong listbox sẽ nộp vào cột M phía dưới hàng có tên "MATERIAL" trong sheet "ELECTRICAL SYSTEM".
+Cột "NHÂN CÔNG" trong listbox sẽ nộp vào cột N phía dưới hàng có tên "LABOUR" trong sheet "ELECTRICAL SYSTEM".
khi nạp vào như vậy thì sẽ tự động nạp vào dòng tiếp theo.
+ khi chọn mục để nạp mình có thể chọn được nhiều mục để nạp cùng lúc.
- 3 ô Texbox khi nhập dữ liệu vào 3 ô, khi nhấn nút "THÊM" dữ liệu sẽ được nạp mới vào dòng tiếp theo của "DSD".
- ô tìm kiếm khi gõ vào ký tự cần tìm thì listbox chỉ xuất hiện những mục mình cần nạp.
- Mình muốn tạo thêm 1 combobox sử dụng userform để nạp cho các sheet còn lại, khi chọn sheet nào trên userform thì sẽ di chuyển đến sheet đó và nhập liệu.(mình chưa tạo combobox).
Thanks mọi người!

dinhdam90 · 15/6/18

Các bác cho em hỏi là em muốn tự động nhập vào thời gian và ngày giờ ở cột F bằng code sau dưới đây. Nhưng em không chạy file này được.
Các bác kiểm tra giúp em sai ở đâu và chỉ cách sửa giúp em với ạ.
Em cảm ơn.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
For i = 2 To 5
    If Cells(i, "B").Value <> "" And Cells(i, "C").Value <> "" And Cells(i, "D").Value <> "" And Cells(i, "E").Value <> "" Then
    Cells(i, "F").Value = Date & Time
    Cells(i, "F").NumberFormat = "d/m/yyyy h:mm AM/PM"
    Range("F:F").EntireColumn = AutoFit
    End If
Next
End Sub

phulien1902 · 15/6/18

dinhdam90 đã viết:
Các bác cho em hỏi là em muốn tự động nhập vào thời gian và ngày giờ ở cột F bằng code sau dưới đây. Nhưng em không chạy file này được.
Các bác kiểm tra giúp em sai ở đâu và chỉ cách sửa giúp em với ạ.
Em cảm ơn.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer For i = 2 To 5 If Cells(i, "B").Value <> "" And Cells(i, "C").Value <> "" And Cells(i, "D").Value <> "" And Cells(i, "E").Value <> "" Then Cells(i, "F").Value = Date & Time Cells(i, "F").NumberFormat = "d/m/yyyy h:mm AM/PM" Range("F:F").EntireColumn = AutoFit End If Next End Sub

Bạn thử:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&
    If Not Intersect(Target, Range("C2:E500")) Is Nothing Then
        If Target.Count = 1 Then
            i = Target.Row
            If Application.WorksheetFunction.CountA(Range("C" & i).Resize(, 3)) = 3 Then
                Range("F" & i).Value = Date
                ' Range("F" & i).NumberFormat = "dd/mm/yyyy hh:mm:ss"
                 Range("F" & i).NumberFormat = "d/m/yyyy h:mm AM/PM"
            Else
                Range("F" & i).ClearContents
            End If
        End If
    End If
End Sub

dinhdam90 · 15/6/18

phulien1902 đã viết:

Bạn thử:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i&
    If Not Intersect(Target, Range("C2:E500")) Is Nothing Then
        If Target.Count = 1 Then
            i = Target.Row
            If Application.WorksheetFunction.CountA(Range("C" & i).Resize(, 3)) = 3 Then
                Range("F" & i).Value = Date
                ' Range("F" & i).NumberFormat = "dd/mm/yyyy hh:mm:ss"
                 Range("F" & i).NumberFormat = "d/m/yyyy h:mm AM/PM"
            Else
                Range("F" & i).ClearContents
            End If
        End If
    End If
End Sub

Cảm ơn bạn.
Sub đã chạy được rồi nhưng bạn có thể giải thích giúp mình sao code của mình không chạy được vậy ?

Hau151978 · 16/6/18

dinhdam90 đã viết:
Cảm ơn bạn.
Sub đã chạy được rồi nhưng bạn có thể giải thích giúp mình sao code của mình không chạy được vậy ?

Code bạn không chạy chính xác do khi nội dung sheet thay đổi thì thủ tục sự kiện chạy gây ra thay đổi nội dung sheet lại kích hoạt thủ tục. Nói chung sự kiện worksheet_change nên gắn với lệnh application.enableevents=false

tonnydung · 28/6/18

Em mới tập tẹ viết VBA. Các bác giúp em với, Em quanh co mãi mà không biết sử lý thế nào được. Tks mọi người.

SA_DQ · 29/6/18

(1) em muốn ở Form khi gõ ở textBoxt trên cùng sẽ lọc ra các dữ liệu cần tìm ở vùng từ cột B đến cột AL mà không cần pahit Click vào Button ALL

Ở trang 'NhapLich' đó, bạn có dữ liệu ở các cột từ [A:A] cho đến [Al:AL]
Vậy TextBox trên cùng cần gõ vô để tìm là trường (cột) nào trong nớ.
Không lẽ tìm trên ngấn í cột để mõi mệt thì nghỉ?
Thông thường, 1 CSDL thường có chí ít 1 cột mà người ta dựa vô đó để xác lập toàn bộ dữ liệu mà nó làm đại diện (toàn bộ dòng dữ liệu)
Vậy bạn cần xác định trước chuyện nhập vô TextBox này dữ liệu thuộc trường/cột nào?

và ở Textboxt NVKD duyệt giá khi gõ vào phải trùng tên với Textboxt NVKD ký Hợp đồng nếu không đúng ko cho nhập và hiển thị ra thông báo

Cái này nên xài ComboBox theo 1 danh sách định trước thì hơn

Em muốn bỏ Textboxt maxKH đi thay vào đó là ComboBox "cbdskhncc" và nó sẽ lấy hiển thị ra chọn tên các mã KH để chọn Khi chọn xong thì Textboxt Tên khách hàng, họ tên khách hàng, số dien thoại sẽ lấy dựa trên Combobox đã chọn

Đây sẽ fải là iêu cầu hàng đầu của bạn mới đúng.
Việc này sẽ thực hiện nhờ trang mà bạn gọi là 'DS_KH_NCC' với những trường được gán tên.
(Nên đổi tên trang tính này lại thành 'DMuc' là đạt rồi, theo mình.)

haianh89 · 29/6/18

Em mới xem vba mà cũng chưa biết thế nào.
Nhờ các bác cho mẫu hoặc hỗ trợ vẽ biểu đồ hình tròn dạng 3D với biên động theo file đính kèm ak.
Cảm ơn mọi người.

vova2209 · 10/7/18

Cho em xin hỏi:
1. Tại sao khi em ấn F8 chạy test từng lệnh, khi hết code nó chạy sang tất cả các Function mà không liên quan đến code. làm thế nào để khắc phục

befaint · 10/7/18

vova2209 đã viết:
Cho em xin hỏi:
1. Tại sao khi em ấn F8 chạy test từng lệnh, khi hết code nó chạy sang tất cả các Function mà không liên quan đến code. làm thế nào để khắc phục

2. Không ấn F8 nữa hay cất phím F8 vào tủ, hoặc kệ nó vì có sao đâu.

vova2209 · 10/7/18

befaint đã viết:
2. Không ấn F8 nữa hay cất phím F8 vào tủ, hoặc kệ nó vì có sao đâu.

^^! he he.. ấn để test code mà anh

Hau151978 · 10/7/18

vova2209 đã viết:
Cho em xin hỏi:
1. Tại sao khi em ấn F8 chạy test từng lệnh, khi hết code nó chạy sang tất cả các Function mà không liên quan đến code. làm thế nào để khắc phục

Khả năng code của bạn có thủ tục sự kiện như worksheet_change nên khi sub đang chạy ghi dữ liệu vào sheet thì thủ tục sự kiện chạy. Nếu không muốn chạy từng lệnh của thủ tục này thì bạn bấm shift - f8 hoặc ctrl-shift-f8

vova2209 · 10/7/18

Hau151978 đã viết:
Khả năng code của bạn có thủ tục sự kiện như worksheet_change nên khi sub đang chạy ghi dữ liệu vào sheet thì thủ tục sự kiện chạy. Nếu không muốn chạy từng lệnh của thủ tục này thì bạn bấm shift - f8 hoặc ctrl-shift-f8

Đúng rồi anh à! Các sheet của em có hàm thủ tục sự kiện để tự động chạy code..

♫ђöล♥ßล†♥†µ♫ · 10/7/18

befaint đã viết:
2. Không ấn F8 nữa hay cất phím F8 vào tủ, hoặc kệ nó vì có sao đâu.

Anh @befaint đúng là chuyên gia bàn phím. Nhưng em thích kiểu ngày xưa của Anh hơn ( Tuy mất 5 nghìn đồng tiền)

vova2209 · 10/7/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Anh @befaint đúng là chuyên gia bàn phím. Nhưng em thích kiểu ngày xưa của Anh hơn ( Tuy mất 5 nghìn đồng tiền)

xem hộ em bài #17, #19 với chị ơi: https://www.giaiphapexcel.com/diend...ode-lấy-dữ-liệu-file-khác.136038/#post-867435

♫ђöล♥ßล†♥†µ♫ · 10/7/18

vova2209 đã viết:
xem hộ em bài #17, #19 với chị ơi: https://www.giaiphapexcel.com/diendan/threads/nhờ-anh-chị-viết-hộ-em-code-lấy-dữ-liệu-file-khác.136038/#post-867435

Anh @HieuCD mà ra tay không được thì em chỉ có nước mà ngồi nhìn thui

ndu96081631 · 10/7/18

vova2209 đã viết:
Cho em xin hỏi:
1. Tại sao khi em ấn F8 chạy test từng lệnh, khi hết code nó chạy sang tất cả các Function mà không liên quan đến code. làm thế nào để khắc phục

Xem chỗ này có giống tình trạng của bạn không
https://www.giaiphapexcel.com/diendan/threads/không-gọi-hàm-mà-nó-vẫn-chạy.135734/
-----------------------

♫ђöล♥ßล†♥†µ♫ đã viết:
Anh @befaint đúng là chuyên gia bàn phím. Nhưng em thích kiểu ngày xưa của Anh hơn ( Tuy mất 5 nghìn đồng tiền)

Thì ra ngày xưa anh @befaint toàn chơi kiểu? Chắc kiểu hay lắm đây nên em Bất Tử thích đến bất tỉnh luôn.
Chia sẻ với anh phèn ơi

vova2209 · 10/7/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Anh @HieuCD mà ra tay không được thì em chỉ có nước mà ngồi nhìn thui

anh Hiếu đang bận đi Uống Rượu nên chưa xem nốt cho em được nên thấy chị rảnh coi cho em tý

vova2209 · 10/7/18

ndu96081631 đã viết:
Xem chỗ này có giống tình trạng của bạn không
https://www.giaiphapexcel.com/diendan/threads/không-gọi-hàm-mà-nó-vẫn-chạy.135734/
-----------------------

Thì ra ngày xưa anh @befaint toàn chơi kiểu? Chắc kiểu hay lắm đây nên em Bất Tử thích đến bất tỉnh luôn.
Chia sẻ với anh phèn ơi

Dạ vâng đúng bị như trường hợp trên ạ. Có sự kiện thay đổi, e cho thêm mấy hàm tắt tính toán là okje rồi ạ. Cảm ơn anh

Bài đã được tự động gộp: 10/7/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Anh @befaint đúng là chuyên gia bàn phím. Nhưng em thích kiểu ngày xưa của Anh hơn ( Tuy mất 5 nghìn đồng tiền)

Anh HiếuCD đi uống Rượu về hộ em rồi.. cảm ơn anh chị nhiều

tonnydung · 14/7/18

Em mới tập tẹ viết VBA nên có mỗi đoạn này ko được nhờ các bác giup. Em có cái Macro để nhập dữ liệu, giờ em đang vướng set nếu E6 = "hq" thì không được để chống ô E16 và E17 . Code em doan duoi khi chay bao lỗi. Nhờ cả nhà giúp em với ah. Tks

Private Sub DieuxeNguyet_Click()

If Range("E6") = "hq" Then

MsgBox "Ban phai nhap ten lxe Cty"

Range("E16").SetFocus

Exit Sub

End If

If Range("E6") = "hq" Then

MsgBox "Ban chua nhap bien so lxe xe Cty se di"

Range("E17").SetFocus

Exit Sub

Else

DieuxeNguyet

End If

End Sub

denell_tran · 16/7/18

Các bác cho em hỏi chút, đoạn code bên dưới em sử dụng sao mỗi lần nhảy vào sheet nó chạy lâu, mất tầm 10"~15". Có cách nào làm nó nhanh hơn không ạ?
Mỗi lần chuyển sheet cứ phải chờ rất khó chịu ạ.
Cám ơn các bác.
Code:
Private Sub Worksheet_Activate()
Dim Rng As Range
Application.ScreenUpdating = False
For Each Rng In [A12:A35]
Rng.EntireRow.Hidden = Rng.Value = ""
Next Rng
End Sub

huonglien1901 · 16/7/18

denell_tran đã viết:
Các bác cho em hỏi chút, đoạn code bên dưới em sử dụng sao mỗi lần nhảy vào sheet nó chạy lâu, mất tầm 10"~15". Có cách nào làm nó nhanh hơn không ạ?
Mỗi lần chuyển sheet cứ phải chờ rất khó chịu ạ.
Cám ơn các bác.
Code:
Private Sub Worksheet_Activate()
Dim Rng As Range
Application.ScreenUpdating = False
For Each Rng In [A12:A35]
Rng.EntireRow.Hidden = Rng.Value = ""
Next Rng
End Sub

Rich (BB code):

Private Sub Worksheet_Activate()

    Dim Rng As Range

    Application.ScreenUpdating = False

    For Each Rng In [A12:A35]

        Rng.EntireRow.Hidden = Rng.Value = ""

    Next Rng
    Application.ScreenUpdating = True

End Sub

befaint · 16/7/18

denell_tran đã viết:
hỏi chút

Cho vào module:

Mã:

Public Sub HideRow_Empty(ByVal sRng As Range)
    Dim Rng As Range, Cll As Range, oldCal
    oldCal = Application.Calculation
    Application.Calculation = xlCalculationManual
    For Each Cll In sRng 'Range("A12:A35")
        If Len(Cll.Value) = 0 Then
            If Rng Is Nothing Then
                Set Rng = Cll
            Else
                Set Rng = Union(Rng, Cll)
            End If
        End If
    Next Cll
    If Not Rng Is Nothing Then Rng.EntireRow.Hidden = True
    Application.Calculation = oldCal
End Sub

Cho vào worksheet

Mã:

Private Sub Worksheet_Activate()
    HideRow_Empty Range("A12:A35")
End Sub

denell_tran · 16/7/18

huonglien1901 đã viết:
Rich (BB code):

Private Sub Worksheet_Activate()

befaint đã viết:
Cho vào module:

End Sub[/code]

Cám ơn các bạn nhiều.

ndu96081631 · 16/7/18

denell_tran đã viết:
Các bác cho em hỏi chút, đoạn code bên dưới em sử dụng sao mỗi lần nhảy vào sheet nó chạy lâu, mất tầm 10"~15". Có cách nào làm nó nhanh hơn không ạ?
Mỗi lần chuyển sheet cứ phải chờ rất khó chịu ạ.
Cám ơn các bác.
Code:
Private Sub Worksheet_Activate()
Dim Rng As Range
Application.ScreenUpdating = False
For Each Rng In [A12:A35]
Rng.EntireRow.Hidden = Rng.Value = ""
Next Rng
End Sub

Code ẩn dòng theo điều kiện kiểu này nên dùng AutoFilter sẽ nhanh hơn

vova2209 · 16/7/18

Chào anh chị! nhờ anh chị xem hộ em code file này: dòng muốn dãn đánh số ở AC, AE
+ Các dòng khác chạy bình thường, chỉ riêng dòng 19 bôi đỏ như dưới hình là chạy lỗi, nhờ anh chị xem giúp em.
++ Lỗi em phát hiện
a. Đại diện đơn vị...
cho số 1 số kí tự nữa thì được
VD: 1a. Đại diện đơn vị
Nhờ anh chị xem lại code để loại bỏ lỗi đó ạ. em xin cảm ơn

Mã:

'FIX ROW CO DAN DÒNG
Sub MergeCellFit(ByVal MergeCells As Range)
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double

    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If

    With MergeCellArea
        ColCount = .Columns.Count
        RowCount = .Rows.Count
        .WrapText = True
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        Set FirstCell = .Cells(1, 1)
            FirstCellWidth = FirstCell.ColumnWidth
            Diff = 0.75
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
            .MergeCells = False
            FirstCell.ColumnWidth = MergeCellWidth - Diff
            .EntireRow.AutoFit
            FirstCellHeight = FirstCell.RowHeight
            .MergeCells = True
            FirstCell.ColumnWidth = FirstCellWidth
            FirstCellHeight = FirstCellHeight / RowCount * 1.15 'Chiêu` cao dòng khi fix sang 2 dòng
            .RowHeight = FirstCellHeight
    End With
ExitSub:
End Sub


Sub CoDanRowBB2() 'Dia chi fixrow o* bang excell
    Dim R1, R2, R3, R4, R5, R6, R7, R8 As Long
        R1 = Range("Q1"): R2 = Range("S1"): R3 = Range("U1"): R4 = Range("W1")
        R5 = Range("Y1"): R6 = Range("AA1"): R7 = Range("AC1"): R8 = Range("AE1")
       
    On Error Resume Next
    MergeCellFit Sheets("BBan").Range("E" & R1) 'Dòng fix dôc lâp.
   
    MergeCellFit Sheets("BBan").Range("T" & R7) 'Dòng fix dôc lâp.
    MergeCellFit Sheets("BBan").Range("T" & R8)
       
    Range("E" & R2).RowHeight = Range("E" & R1).RowHeight 'Chiêu` cao bàng dòng R1 (Q1)
    Range("E" & R3).RowHeight = Range("E" & R1).RowHeight
    Range("E" & R4).RowHeight = Range("E" & R1).RowHeight
    Range("E" & R5).RowHeight = Range("E" & R1).RowHeight
    Range("E" & R6).RowHeight = Range("E" & R1).RowHeight
End Sub

huuthang_bd · 16/7/18

vova2209 đã viết:

Chào anh chị! nhờ anh chị xem hộ em code file này: dòng muốn dãn đánh số ở AC, AE
+ Các dòng khác chạy bình thường, chỉ riêng dòng 19 bôi đỏ như dưới hình là chạy lỗi, nhờ anh chị xem giúp em.
++ Lỗi em phát hiện
a. Đại diện đơn vị...
cho số 1 số kí tự nữa thì được
VD: 1a. Đại diện đơn vị
Nhờ anh chị xem lại code để loại bỏ lỗi đó ạ. em xin cảm ơn

Mã:

'FIX ROW CO DAN DÒNG
Sub MergeCellFit(ByVal MergeCells As Range)
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double

    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If

    With MergeCellArea
        ColCount = .Columns.Count
        RowCount = .Rows.Count
        .WrapText = True
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        Set FirstCell = .Cells(1, 1)
            FirstCellWidth = FirstCell.ColumnWidth
            Diff = 0.75
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
            .MergeCells = False
            FirstCell.ColumnWidth = MergeCellWidth - Diff
            .EntireRow.AutoFit
            FirstCellHeight = FirstCell.RowHeight
            .MergeCells = True
            FirstCell.ColumnWidth = FirstCellWidth
            FirstCellHeight = FirstCellHeight / RowCount * 1.15 'Chiêu` cao dòng khi fix sang 2 dòng
            .RowHeight = FirstCellHeight
    End With
ExitSub:
End Sub


Sub CoDanRowBB2() 'Dia chi fixrow o* bang excell
    Dim R1, R2, R3, R4, R5, R6, R7, R8 As Long
        R1 = Range("Q1"): R2 = Range("S1"): R3 = Range("U1"): R4 = Range("W1")
        R5 = Range("Y1"): R6 = Range("AA1"): R7 = Range("AC1"): R8 = Range("AE1")
      
    On Error Resume Next
    MergeCellFit Sheets("BBan").Range("E" & R1) 'Dòng fix dôc lâp.
  
    MergeCellFit Sheets("BBan").Range("T" & R7) 'Dòng fix dôc lâp.
    MergeCellFit Sheets("BBan").Range("T" & R8)
      
    Range("E" & R2).RowHeight = Range("E" & R1).RowHeight 'Chiêu` cao bàng dòng R1 (Q1)
    Range("E" & R3).RowHeight = Range("E" & R1).RowHeight
    Range("E" & R4).RowHeight = Range("E" & R1).RowHeight
    Range("E" & R5).RowHeight = Range("E" & R1).RowHeight
    Range("E" & R6).RowHeight = Range("E" & R1).RowHeight
End Sub

View attachment 199692

Cái này do thuật toán của code không chính xác chứ không phải lỗi gì cả. Code của topic nào thì bạn vào topic đó hỏi để tác giả khắc phục.

vova2209 · 16/7/18

huuthang_bd đã viết:
Cái này do thuật toán của code không chính xác chứ không phải lỗi gì cả. Code của topic nào thì bạn vào topic đó hỏi để tác giả khắc phục.

Dạ vâng! em cảm ơn anh để em tìm liên hệ Tác Giả

denell_tran · 16/7/18

ndu96081631 đã viết:
Code ẩn dòng theo điều kiện kiểu này nên dùng AutoFilter sẽ nhanh hơn

Em cám ơn bác, em đã làm thử theo 2 cách, kết quả là cách của bạn Befaint ở trên nhanh và đơn giản hơn ạ.

ndu96081631 · 16/7/18

denell_tran đã viết:
Em cám ơn bác, em đã làm thử theo 2 cách, kết quả là cách của bạn Befaint ở trên nhanh và đơn giản hơn ạ.

Còn tôi nghĩ AutoFilter mới đơn giản nhất, chỉ 1 dòng code là đủ. Bạn tin không?

AutoReply · 16/7/18

ndu96081631 đã viết:
Còn tôi nghĩ AutoFilter mới đơn giản nhất, chỉ 1 dòng code là đủ. Bạn tin không?

dạ em hổng có tin anh đâu, anh phải làm sao em mới tin anh chứ. !$@!!

truongvu317 · 16/7/18

AutoReply đã viết:
dạ em hổng có tin anh đâu, anh phải làm sao em mới tin anh chứ.

Thì đè ra chứ làm sao, đã nghe câu lấy thịt đè người chưa.

tueyennhi · 19/7/18

Trong VBA có cách nào để làm tròn số giờ trong mảng không anh chị
Ví dụ tại mảng Arr(i,j) của em có giá trị là 8:00:49s em muốn làm tròn thành 8:00:00 thì làm thế nào. Hay nói cách khác là cắt hẳn cái số giây đi.

huuthang_bd · 19/7/18

tueyennhi đã viết:
Trong VBA có cách nào để làm tròn số giờ trong mảng không anh chị
Ví dụ tại mảng Arr(i,j) của em có giá trị là 8:00:49s em muốn làm tròn thành 8:00:00 thì làm thế nào. Hay nói cách khác là cắt hẳn cái số giây đi.

Bạn thử vầy xem

Mã:

Arr(i, j)  = Int(Arr(i, j)  * 1440)/1440

tueyennhi · 19/7/18

huuthang_bd đã viết:
Bạn thử vầy xem

Mã:

Arr(i, j) = Int(Arr(i, j) * 1440)/1440

Đúng cái mình cần rồi. Cảm ơn bạn nhé

VetMini · 19/7/18

tueyennhi đã viết:
Trong VBA có cách nào để làm tròn số giờ trong mảng không anh chị
Ví dụ tại mảng Arr(i,j) của em có giá trị là 8:00:49s em muốn làm tròn thành 8:00:00 thì làm thế nào. Hay nói cách khác là cắt hẳn cái số giây đi.

???
Cắt hẳn số giây là làm tròn số phút. Làm tròn số giờ thì phải cắt luôn số phút.
Hàm MRound có thể làm chuyện này dễ dàng
= Application.MRound(x, "1:00") ' tròn thành giờ, cắt phút
= Application.MRound(x, "0:01") ' tròn thành phút, cắt giây

canhbinh0610 · 19/7/18

Như file đính kèm, ở sheet 1 em có RẤT NHIỀU BẢNG (em chỉ liệt kê 3 bảng nhưng thực ra có khoảng 20-30 bảng như vậy) chứa thông tin.
Ở sheet 2 em muốn nó sẽ tổng hợp tất cả thông tin theo từng MARK NO. (Như em đã tổng hợp sẵn nhưng nó tốn rất nhiều thời gian vì phải copy vs paste từng dòng rồi lại phải lọc MARK NO. đó có số lượng hay không) Như sheet 2, em phải lọc tất cả những item mà MARK NO. có số lượng, cụ thể lọc từ A1 đến A4 rồi tiếp tục từ X1 đến X6, C1 đến C3.... Rồi phải xoá những dòng có số lượng bằng 0.
Nhờ các bác giúp đỡ dùm.

Bài đã được tự động gộp: 19/7/18

Như file đính kèm, ở sheet 1 em có RẤT NHIỀU BẢNG (em chỉ liệt kê 3 bảng nhưng thực ra có khoảng 20-30 bảng như vậy) chứa thông tin.
Ở sheet 2 em muốn nó sẽ tổng hợp tất cả thông tin theo từng MARK NO. (Như em đã tổng hợp sẵn nhưng nó tốn rất nhiều thời gian vì phải copy vs paste từng dòng rồi lại phải lọc MARK NO. đó có số lượng hay không) Như sheet 2, em phải lọc tất cả những item mà MARK NO. có số lượng, cụ thể lọc từ A1 đến A4 rồi tiếp tục từ X1 đến X6, C1 đến C3.... Rồi phải xoá những dòng có số lượng bằng 0.
Nhờ các bác giúp đỡ dùm.

♫ђöล♥ßล†♥†µ♫ · 19/7/18

canhbinh0610 đã viết:
Như file đính kèm, ở sheet 1 em có RẤT NHIỀU BẢNG (em chỉ liệt kê 3 bảng nhưng thực ra có khoảng 20-30 bảng như vậy) chứa thông tin.
Ở sheet 2 em muốn nó sẽ tổng hợp tất cả thông tin theo từng MARK NO. (Như em đã tổng hợp sẵn nhưng nó tốn rất nhiều thời gian vì phải copy vs paste từng dòng rồi lại phải lọc MARK NO. đó có số lượng hay không) Như sheet 2, em phải lọc tất cả những item mà MARK NO. có số lượng, cụ thể lọc từ A1 đến A4 rồi tiếp tục từ X1 đến X6, C1 đến C3.... Rồi phải xoá những dòng có số lượng bằng 0.
Nhờ các bác giúp đỡ dùm.

Bài đã được tự động gộp: 19/7/18

Như file đính kèm, ở sheet 1 em có RẤT NHIỀU BẢNG (em chỉ liệt kê 3 bảng nhưng thực ra có khoảng 20-30 bảng như vậy) chứa thông tin.
Ở sheet 2 em muốn nó sẽ tổng hợp tất cả thông tin theo từng MARK NO. (Như em đã tổng hợp sẵn nhưng nó tốn rất nhiều thời gian vì phải copy vs paste từng dòng rồi lại phải lọc MARK NO. đó có số lượng hay không) Như sheet 2, em phải lọc tất cả những item mà MARK NO. có số lượng, cụ thể lọc từ A1 đến A4 rồi tiếp tục từ X1 đến X6, C1 đến C3.... Rồi phải xoá những dòng có số lượng bằng 0.
Nhờ các bác giúp đỡ dùm.

Bạn xem lại file mẫu. Tại bảng 1 MARK NO.(A2) có 4 dòng khác không sao sang Sheet2 nó lại có 3 dòng vậy

PHP:

Sub Thu_ti_thoi()
    Dim sArr, dArr(1 To 65535, 1 To 10)
    Dim I As Long, fI As Long, K As Long, LastRow As Long, Ir As Long
    Dim Id As Long, Ic As Long, Itb As Long, Col As Long, J As Long
With Sheet1
    LastRow = .Range("H65535").End(xlUp).Row
    sArr = .Range("A1:M" & LastRow)
    fI = 1
    For I = fI To UBound(sArr)
        If sArr(I, 8) = "ITEM" Then Ir = I
        Id = .Range("H" & Ir).End(xlDown).Row
        Ic = .Range("H" & Id).End(xlDown).Row
        If Ic <= UBound(sArr) Then
            For Col = 7 To 1 Step -1
                For Itb = Id To Ic
                    If sArr(Itb, Col) <> Empty Then
                        K = K + 1
                        dArr(K, 1) = K
                        dArr(K, 2) = sArr(Id - 2, Col)
                        dArr(K, 3) = sArr(Itb, 8)
                        For J = 9 To 13
                            dArr(K, J - 5) = sArr(Itb, J)
                        Next J
                        dArr(K, 9) = sArr(Id - 1, Col) * sArr(Itb, Col)
                        dArr(K, 10) = "=RC[-3]*RC[-1]"
                    End If
                Next Itb
            Next Col
            fI = Ic + 1
        End If
    Next I
End With
With Sheet2
    If K Then
        LastRow = .Range("L65535").End(xlUp).Row
        .Range("L2").Resize(LastRow, 10).ClearContents
        .Range("L2").Resize(K, 10) = dArr
    End If
End With
End Sub

HieuCD · 19/7/18

♫ђöล♥ßล†♥†µ♫ đã viết:

Bạn xem lại file mẫu. Tại bảng 1 MARK NO.(A2) có 4 dòng khác không sao sang Sheet2 nó lại có 3 dòng vậy

PHP:

Sub Thu_ti_thoi()
    Dim sArr, dArr(1 To 65535, 1 To 10)
    Dim I As Long, fI As Long, K As Long, LastRow As Long, Ir As Long
    Dim Id As Long, Ic As Long, Itb As Long, Col As Long, J As Long
With Sheet1
    LastRow = .Range("H65535").End(xlUp).Row
    sArr = .Range("A1:M" & LastRow)
    fI = 1
    For I = fI To UBound(sArr)
        If sArr(I, 8) = "ITEM" Then Ir = I
        Id = .Range("H" & Ir).End(xlDown).Row
        Ic = .Range("H" & Id).End(xlDown).Row
        If Ic <= UBound(sArr) Then
            For Col = 7 To 1 Step -1
                For Itb = Id To Ic
                    If sArr(Itb, Col) <> Empty Then
                        K = K + 1
                        dArr(K, 1) = K
                        dArr(K, 2) = sArr(Id - 2, Col)
                        dArr(K, 3) = sArr(Itb, 8)
                        For J = 9 To 13
                            dArr(K, J - 5) = sArr(Itb, J)
                        Next J
                        dArr(K, 9) = sArr(Id - 1, Col) * sArr(Itb, Col)
                        dArr(K, 10) = "=RC[-3]*RC[-1]"
                    End If
                Next Itb
            Next Col
            fI = Ic + 1
        End If
    Next I
End With
With Sheet2
    If K Then
        LastRow = .Range("L65535").End(xlUp).Row
        .Range("L2").Resize(LastRow, 10).ClearContents
        .Range("L2").Resize(K, 10) = dArr
    End If
End With
End Sub

Kỳ ha, sao chạy code không giống đáp án tý nào

denell_tran · 20/7/18

ndu96081631 đã viết:
Còn tôi nghĩ AutoFilter mới đơn giản nhất, chỉ 1 dòng code là đủ. Bạn tin không?

Em tin là chỉ 1 dòng code, nhưng bảng của em nó còn lắm thứ khác, nên để filter cho chuẩn thì lại phải tạo điều kiện lọc cho các dòng khác, không nó lọc luôn đi mất. Em đang mấy mò làm mấy cái này nên hơi lơ ngơ. Cám ơn bác ạ.

ndu96081631 · 20/7/18

denell_tran đã viết:
Em tin là chỉ 1 dòng code, nhưng bảng của em nó còn lắm thứ khác, nên để filter cho chuẩn thì lại phải tạo điều kiện lọc cho các dòng khác, không nó lọc luôn đi mất. Em đang mấy mò làm mấy cái này nên hơi lơ ngơ. Cám ơn bác ạ.

Ủa là sao hả bạn? Đằng nào thì code cũng lọc những giá trị khác rổng tại cột A, tức ẩn những giá trị rổng. Vậy chẳng phải nếu dùng AutoFilter cũng đi đến cùng kêt quả sao?
Hình như bạn chưa biết code AutoFilter thì phải? Thôi thì bạn cứ làm bằng tay và record macro quá trình sẽ thấy ngay code

canhbinh0610 · 20/7/18

♫ђöล♥ßล†♥†µ♫ đã viết:

Bạn xem lại file mẫu. Tại bảng 1 MARK NO.(A2) có 4 dòng khác không sao sang Sheet2 nó lại có 3 dòng vậy

PHP:

Sub Thu_ti_thoi()
    Dim sArr, dArr(1 To 65535, 1 To 10)
    Dim I As Long, fI As Long, K As Long, LastRow As Long, Ir As Long
    Dim Id As Long, Ic As Long, Itb As Long, Col As Long, J As Long
With Sheet1
    LastRow = .Range("H65535").End(xlUp).Row
    sArr = .Range("A1:M" & LastRow)
    fI = 1
    For I = fI To UBound(sArr)
        If sArr(I, 8) = "ITEM" Then Ir = I
        Id = .Range("H" & Ir).End(xlDown).Row
        Ic = .Range("H" & Id).End(xlDown).Row
        If Ic <= UBound(sArr) Then
            For Col = 7 To 1 Step -1
                For Itb = Id To Ic
                    If sArr(Itb, Col) <> Empty Then
                        K = K + 1
                        dArr(K, 1) = K
                        dArr(K, 2) = sArr(Id - 2, Col)
                        dArr(K, 3) = sArr(Itb, 8)
                        For J = 9 To 13
                            dArr(K, J - 5) = sArr(Itb, J)
                        Next J
                        dArr(K, 9) = sArr(Id - 1, Col) * sArr(Itb, Col)
                        dArr(K, 10) = "=RC[-3]*RC[-1]"
                    End If
                Next Itb
            Next Col
            fI = Ic + 1
        End If
    Next I
End With
With Sheet2
    If K Then
        LastRow = .Range("L65535").End(xlUp).Row
        .Range("L2").Resize(LastRow, 10).ClearContents
        .Range("L2").Resize(K, 10) = dArr
    End If
End With
End Sub

Đúng rồi đó bạn, đó là lỗi của mình. Chính vì lý do vừa mất thời gian vừa lại hay nhập sai như vậy mình mới cần các bạn giúp đỡ.
Như code của bạn thì mình thấy nó đi đúng hướng nhưng hình như nó có vấn đề với vòng lặp.
Như bài mình đã điền thủ công thì giá trị ở cột B sẽ chạy lần lượt từ A1 đến A cuối (phải sang trái) rồi tiếp tục X1 đến X cuối bên trái, C1 đến C cuối bên trái...... Và nó có bao nhiêu giá trị khác 0 thì sẽ có bấy nhiêu dòng chứa nó. Nhưng khi chạy code của bạn thì có quá nhiều dòng được lặp lại không cần thiết.
Mong bạn xem lại giúp mình. Mình cảm ơn!

denell_tran · 25/7/18

Các bác giúp em sửa cái bên dưới này với. Em không học về lập trình mà chỉ mầy mò tự làm mấy cái mình cần thôi nên kém lắm ạ.
Chuyện là vầy, em lượm được đoạn code của bác @ndu96081631 để in sheet em cần thành .pdf, em copy vào module. Nhưng em muốn làm tự động để mỗi khi em in ra 1 cái thì nó sẽ sao lưu ra 1 file .pdf đặt ở một vị trí trong thư mục backup. Nên em đặt Call đấy trong ThisWorkbook. Nhưng khi chạy thì nó báo lỗi
Runtime error '28'
OUT OF STACK SPACE.

Nhờ các bác sửa giúp cho hết lỗi ạ.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Call PDF
End Sub
----
Sub PDF()
Dim wks As Worksheet
Dim FileName As String
Set wks = ActiveSheet
'With ThisWorkbook
FileName = "C:\Backup\PAYMENT SLIPS" & "\Prntd_" & wks.Range("G8").Value & "_PS No." & wks.Range("A13").Value & Format(Now, "_yymmdd_hhmmss")
'Worksheets.Select
wks.ExportAsFixedFormat 0, FileName
wks.Select
'End With
End Sub

Hau151978 · 25/7/18

denell_tran đã viết:
Các bác giúp em sửa cái bên dưới này với. Em không học về lập trình mà chỉ mầy mò tự làm mấy cái mình cần thôi nên kém lắm ạ.
Chuyện là vầy, em lượm được đoạn code của bác @ndu96081631 để in sheet em cần thành .pdf, em copy vào module. Nhưng em muốn làm tự động để mỗi khi em in ra 1 cái thì nó sẽ sao lưu ra 1 file .pdf đặt ở một vị trí trong thư mục backup. Nên em đặt Call đấy trong ThisWorkbook. Nhưng khi chạy thì nó báo lỗi
Runtime error '28'
OUT OF STACK SPACE.

Nhờ các bác sửa giúp cho hết lỗi ạ.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Call PDF
End Sub
----
Sub PDF()
Dim wks As Worksheet
Dim FileName As String
Set wks = ActiveSheet
'With ThisWorkbook
FileName = "C:\Backup\PAYMENT SLIPS" & "\Prntd_" & wks.Range("G8").Value & "_PS No." & wks.Range("A13").Value & Format(Now, "_yymmdd_hhmmss")
'Worksheets.Select
wks.ExportAsFixedFormat 0, FileName
wks.Select
'End With
End Sub

Nhiều khả năng lệnh exportasfixedformat kích hoạt lại thủ tục Workbook_BeforePrint gây tràn stack. Bạn thử sửa thành
Private Sub Workbook_BeforePrint(Cancel As Boolean)
dim xxx as boolean
xxx=application.enableevents
application.enableevents=false
Call PDF
application.enableevents=xxx
End Sub

denell_tran · 25/7/18

Hau151978 đã viết:
Nhiều khả năng lệnh exportasfixedformat kích hoạt lại thủ tục Workbook_BeforePrint gây tràn stack. Bạn thử sửa thành
Private Sub Workbook_BeforePrint(Cancel As Boolean)
dim xxx as boolean
xxx=application.enableevents
application.enableevents=false
Call PDF
application.enableevents=xxx
End Sub

Bạn nói đúng quá, mình làm lại như bạn viết, chạy chuẩn luôn. Cám ơn bạn nhiều lắm!

nguyenthuy13388 · 26/7/18

Dear all

mình có đoạn code như dưới đây, tuy nhiên khi rất chậm, mình lại đang đặt nó với sự kiện open workbook nên cần nó chạy nhaanh hơn 1 chút,
ai có cách nào cải thiện tốc độ giúp mình trong trường hợp này không

Mã:

Sub xu_ly_thong_bao_sheet_co_ban()
'Sheet1.Shapes("Rectangular Callout 50").Visible = msoFalse ' ân dôi tuong
'Sheet1.Shapes("Rectangular Callout 50").Visible = msoTrue ' hien doi tuong
Dim CB_dang_ky As Long, CB_dang_kiem As Long, CB_bao_hiem As Long, CB_phi_bao_tri As Long, CB_phu_hieu As Long, CB_bao_duong As Long, CB_thay_lop As Long, CB_thay_ac_quy As Long
Dim i As Long
LR = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row ' hiện LR mới đến khoảng 300
For i = 5 To LR
Sheet2.Cells(i, "AA").Value = Application.WorksheetFunction.YearFrac(Sheet2.Range("K" & i), CLng(Date), 3)
Next i
CB_dang_ky = Application.WorksheetFunction.CountIf(Sheet2.Range("AA5:AA" & i), ">24") 'dem so ngay lon today - 7 trong cot "N"
Sheet1.Shapes("Rectangle 57").TextFrame2.TextRange.Characters.Text = CB_dang_ky 'dien ky tu vao doi tuong
Sheet2.Range("AA5:AA" & i).ClearContents
CB_dang_kiem = Application.WorksheetFunction.CountIfs(Sheet2.Range("N5:N1000"), "<=" & CLng(Date) + 7)  ' dem so ngay nho hon today + 7 trong cot "N"
Sheet1.Shapes("Rectangle 53").TextFrame2.TextRange.Characters.Text = CB_dang_kiem 'dien ky tu vao doi tuong
CB_bao_hiem = Application.WorksheetFunction.CountIfs(Sheet2.Range("P5:P1000"), "<=" & CLng(Date) + 30)  ' dem so ngay nho hon today + 30 trong cot "P"
Sheet1.Shapes("Rectangle 63").TextFrame2.TextRange.Characters.Text = CB_bao_hiem 'dien ky tu vao doi tuong
CB_phi_bao_tri = Application.WorksheetFunction.CountIfs(Sheet2.Range("S5:S1000"), "<=" & CLng(Date) + 30)  ' dem so ngay nho hon today + 30 trong cot "S"
Sheet1.Shapes("Rectangle 66").TextFrame2.TextRange.Characters.Text = CB_phi_bao_tri 'dien ky tu vao doi tuong
CB_phu_hieu = Application.WorksheetFunction.CountIfs(Sheet2.Range("R5:R1000"), "<=" & CLng(Date) + 60)  ' dem so ngay nho hon today +60 trong cot "R"
Sheet1.Shapes("Rectangle 69").TextFrame2.TextRange.Characters.Text = CB_phu_hieu 'dien ky tu vao doi tuong
End Sub

nguyenthuy13388 · 26/7/18

nguyenthuy13388 đã viết:

Dear all

mình có đoạn code như dưới đây, tuy nhiên khi rất chậm, mình lại đang đặt nó với sự kiện open workbook nên cần nó chạy nhaanh hơn 1 chút,
ai có cách nào cải thiện tốc độ giúp mình trong trường hợp này không

Mã:

Sub xu_ly_thong_bao_sheet_co_ban()
'Sheet1.Shapes("Rectangular Callout 50").Visible = msoFalse ' ân dôi tuong
'Sheet1.Shapes("Rectangular Callout 50").Visible = msoTrue ' hien doi tuong
Dim CB_dang_ky As Long, CB_dang_kiem As Long, CB_bao_hiem As Long, CB_phi_bao_tri As Long, CB_phu_hieu As Long, CB_bao_duong As Long, CB_thay_lop As Long, CB_thay_ac_quy As Long
Dim i As Long
LR = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row ' hiện LR mới đến khoảng 300
For i = 5 To LR
Sheet2.Cells(i, "AA").Value = Application.WorksheetFunction.YearFrac(Sheet2.Range("K" & i), CLng(Date), 3)
Next i
CB_dang_ky = Application.WorksheetFunction.CountIf(Sheet2.Range("AA5:AA" & i), ">24") 'dem so ngay lon today - 7 trong cot "N"
Sheet1.Shapes("Rectangle 57").TextFrame2.TextRange.Characters.Text = CB_dang_ky 'dien ky tu vao doi tuong
Sheet2.Range("AA5:AA" & i).ClearContents
CB_dang_kiem = Application.WorksheetFunction.CountIfs(Sheet2.Range("N5:N1000"), "<=" & CLng(Date) + 7)  ' dem so ngay nho hon today + 7 trong cot "N"
Sheet1.Shapes("Rectangle 53").TextFrame2.TextRange.Characters.Text = CB_dang_kiem 'dien ky tu vao doi tuong
CB_bao_hiem = Application.WorksheetFunction.CountIfs(Sheet2.Range("P5:P1000"), "<=" & CLng(Date) + 30)  ' dem so ngay nho hon today + 30 trong cot "P"
Sheet1.Shapes("Rectangle 63").TextFrame2.TextRange.Characters.Text = CB_bao_hiem 'dien ky tu vao doi tuong
CB_phi_bao_tri = Application.WorksheetFunction.CountIfs(Sheet2.Range("S5:S1000"), "<=" & CLng(Date) + 30)  ' dem so ngay nho hon today + 30 trong cot "S"
Sheet1.Shapes("Rectangle 66").TextFrame2.TextRange.Characters.Text = CB_phi_bao_tri 'dien ky tu vao doi tuong
CB_phu_hieu = Application.WorksheetFunction.CountIfs(Sheet2.Range("R5:R1000"), "<=" & CLng(Date) + 60)  ' dem so ngay nho hon today +60 trong cot "R"
Sheet1.Shapes("Rectangle 69").TextFrame2.TextRange.Characters.Text = CB_phu_hieu 'dien ky tu vao doi tuong
End Sub

Có ai quan tâm không nhỉ?

ndu96081631 · 26/7/18

nguyenthuy13388 đã viết:
Có ai quan tâm không nhỉ?

Quan tâm cũng bó tay thôi. Không có dữ liệu thì lấy gì test?
Trong code toàn dùng WorksheetFunction, vậy thôi gõ trực tiếp lên bảng tính luôn cho rồi, khỏi code, khỏi sự kiện Open gì ráo

giaiphap · 26/7/18

ndu96081631 đã viết:
Quan tâm cũng bó tay thôi. Không có dữ liệu thì lấy gì test?
Trong code toàn dùng WorksheetFunction, vậy thôi gõ trực tiếp lên bảng tính luôn cho rồi, khỏi code, khỏi sự kiện Open gì ráo

Có code nhìn mới pro anh ơi.

nguyenthuy13388 · 26/7/18

ndu96081631 đã viết:
Quan tâm cũng bó tay thôi. Không có dữ liệu thì lấy gì test?
Trong code toàn dùng WorksheetFunction, vậy thôi gõ trực tiếp lên bảng tính luôn cho rồi, khỏi code, khỏi sự kiện Open gì ráo

Cảm ơn Bác,

em đã giải quyết được vấn để rồi ạ, do code em dùng vòng lặp For duyệt từng dòng nên nó chạy lâu.
vậy là em tạo cột phụ gán giá trị cho cả mảng sau đó lại xóa cột phụ đi

Bài đã được tự động gộp: 26/7/18

giaiphap đã viết:
Có code nhìn mới pro anh ơi.

thực ra là ngại tách 1 chức năng ra khỏi 1 file công kềnh thôi

yenmaiyeu · 26/7/18

Nhờ các cao thủ giúp mình tại sao mình tìm dòng cuối của bảng (chỗ bôi đậm) mà nó cứ bảo lỗi 424:
Sub luudulieu()
'
' luudulieu Macro
'

'
Sheets("Nhaplieu").Select
Range("C7:C9").Select
Selection.ClearContents

Range("C3:C9").Select
Selection.Copy
Sheets("Data").Select
Dim DongCuoi As Long
DongCuoi = Data.Cells(Row.Count, 1).End(xlUp).Row + 1
Data.Range("A" & DongCuoi & ":" & "G" & DongCuoi).Value = Data.Range("B4:H4").Value
Range("A" & DongCuoi).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
Xin chân thành cảm ơn các bạn.

truongvu317 · 26/7/18

yenmaiyeu đã viết:
Row.Count

Có vẻ phải là rows.count

hanoimuathu.uet · 26/7/18

em có xem 1 hướng dẫn trên youtbe việc viết hàm tìm kiếm data từ listbox nhưng bị lỗi Permission denied ( Run time error '70' ).
Mn có ai biết sửa lỗi này ko ạ?
Thank and Best Regards,

giaiphap · 26/7/18

hanoimuathu.uet đã viết:
em có xem 1 hướng dẫn trên youtbe việc viết hàm tìm kiếm data từ listbox nhưng bị lỗi Permission denied ( Run time error '70' ).
Mn có ai biết sửa lỗi này ko ạ?
Thank and Best Regards,

Muốn giúp phải thấy mặt mày file và code ra sao chứ hỏi vậy ai dám trả lời được.

hanoimuathu.uet · 27/7/18

giaiphap đã viết:
Muốn giúp phải thấy mặt mày file và code ra sao chứ hỏi vậy ai dám trả lời được.

dạ e add thêm file ạ
e làm userform để add data, và muốn tìm tem lỗi theo dữ liệu đã quy định nhưng đến bước save lại lỗi

be_09 · 27/7/18

yenmaiyeu đã viết:
Nhờ các cao thủ giúp mình tại sao mình tìm dòng cuối của bảng (chỗ bôi đậm) mà nó cứ bảo lỗi 424:
Sub luudulieu()
'
' luudulieu Macro
'

'
Sheets("Nhaplieu").Select
Range("C7:C9").Select
Selection.ClearContents

Range("C3:C9").Select
Selection.Copy
Sheets("Data").Select
Dim DongCuoi As Long
DongCuoi = Data.Cells(Row.Count, 1).End(xlUp).Row + 1
Data.Range("A" & DongCuoi & ":" & "G" & DongCuoi).Value = Data.Range("B4:H4").Value
Range("A" & DongCuoi).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
Xin chân thành cảm ơn các bạn.

Thay thử code sau vào nhé.

Mã:

Sub luudulieu()
    Sheets("Nhaplieu").Range("C3:C9").Copy
    Sheets("Data").Range("A65536").End(xlUp).Offset(1).PasteSpecial Transpose:=True
    Sheets("Nhaplieu").Range("C7:C9").ClearContents
End Sub

VetMini · 27/7/18

hanoimuathu.uet đã viết:
Mn có ai biết sửa lỗi này ko ạ?
Thank and Best Regards,

Đem qua mục "Học Tiếng Anh" mà hỏi.
Nhưng tốt hơn hết là kiếm mấy cái diễn đàn của Việt Kiều Mẽo. Dù gì thì những người đó có nói tiếng Mẽo sai cũng không ai cãi nổi.

yenmaiyeu · 27/7/18

be09 đã viết:
Thay thử code sau vào nhé.

Mã:

Sub luudulieu() Sheets("Nhaplieu").Range("C3:C9").Copy Sheets("Data").Range("A65536").End(xlUp).Offset(1).PasteSpecial Transpose:=True Sheets("Nhaplieu").Range("C7:C9").ClearContents End Sub

Giúp mình tí nữa được không: mình muốn chỉ dán dữ liệu thôi thì làm sao bạn nhỉ?

nguyenthuy13388 · 27/7/18

yenmaiyeu đã viết:
Giúp mình tí nữa được không: mình muốn chỉ dán dữ liệu thôi thì làm sao bạn nhỉ?

Mã:

Sheets("Data").Range("A65536").End(xlUp).Offset(1).PasteSpecial Transpose:=True, Paste:=xlPasteValues

tueyennhi · 27/7/18

Đoạn code dưới đây em dùng để xử lý dữ liệu có 170.000 dòng và 12 cột.
Dữ liệu nguồn dạng dọc (dữ liệu có 170.000 dòng và 12 cột)
Dữ liệu đíc em muốn chuyển thành dạng ngang (Dữ liệu đíc có 125 cột)
Nhưng máy em khi chạy báo Out of memory. Cho em hỏi các biến của em trong code này đã đúng hay chưa?

PHP:

Public Sub BCC_erp()
    Dim Dic As Object, Col As Object, Ws As Worksheet, Tem As String, Tem1 As String, Rws As Long
    Dim R As Long, i As Long, j As Long, K As Long, C As Long, H As Long
    Dim sArr As Variant, dArr(1 To 500000, 1 To 135)
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Col = CreateObject("Scripting.Dictionary")
    With Application
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With
    K = 0
    C = 0
    With Sheets("BCC")
        If CStr(.Range("H8")) <> "" Then
            .Range("J8:FD" & .Range("J" & Rows.Count).End(xlUp).Row).Clear
        End If
        sArr = .Range("J2").Resize(6, 125).Value
        For j = 2 To 125
            If sArr(1, j) <> Empty Then
                If IsDate(sArr(1, j)) Then
                    Col.Item(Day(sArr(1, j)) & sArr(6, j)) = j
                End If
            End If
        Next j
        '...............Dinh dang mau ngay chu nhat........................'
        For j = 12 To 132 Step 4
            If .Cells(6, j).Value Like "Sunday" Then
                .Cells(6, j).Offset(-2, -1).Resize(1, 4).Interior.Color = 49407
            Else
                .Cells(6, j).Offset(-2, -1).Resize(1, 4).Interior.Color = xlNone
            End If
        Next j
    End With
    With Sheets("Data2")
        sArr = .Range("A5", .Range("A300000").End(xlUp)).Resize(, 12).Value
        R = UBound(sArr, 1)
        For i = 1 To R
                Tem1 = Day(sArr(i, 1)) & sArr(i, 12)
                If Col.Exists(Tem1) Then
                    C = Col.Item(Tem1)
                    Tem = sArr(i, 2)
                    If Len(sArr(i, 2)) = 5 Then
                        If Not Dic.Exists(Tem) Then
                            K = K + 1
                            Dic.Add Tem, K
                            dArr(K, 1) = sArr(i, 2)
                        End If
                        Rws = Dic.Item(Tem)
                        dArr(Rws, C) = dArr(Rws, C) + sArr(i, 11)
                    End If
                End If
        Next i
    End With
    With Sheets("BCC")
        If K Then
            .Range("J8").Resize(K, 125) = dArr
            .Range("A4").Resize(, 162).Copy
            .Range("A8").Resize(K, 162).PasteSpecial Paste:=xlPasteFormats
            .Rows(K + 8 & ":" & K + 5000).Clear
        End If
    End With
    Set Dic = Nothing
    Set Col = Nothing
    With Application
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With
End Sub

Em đã đọc đi đoc lại về trường hợp gần tương tự của em trong chủ đề này
https://www.giaiphapexcel.com/diendan/threads/lối-out-of-memory.79903/
Nhưng em không hiểu cần sửa đổi code như thế nào cho phải. Dữ liệu trong mảng của em có cả dạng số và chữ. Mặc dù dữ liệu gốc là 170.000 dòng nhưng khi tổng hợp nếu thành công thì chỉ còn hơn 3000 dòng mà thôi. Rất mong mọi người giúp em. .
Em cảm ơn!

VetMini · 27/7/18

tueyennhi đã viết:
Em đã đọc đi đoc lại về trường hợp gần tương tự của em trong chủ đề này
https://www.giaiphapexcel.com/diendan/threads/lối-out-of-memory.79903/
Nhưng em không hiểu cần sửa đổi code như thế nào cho phải. Dữ liệu trong mảng của em có cả dạng số và chữ. Mặc dù dữ liệu gốc là 170.000 dòng nhưng khi tổng hợp nếu thành công thì chỉ còn hơn 3000 dòng mà thôi. Rất mong mọi người giúp em. .
Em cảm ơn!

Cần đọc kỹ hơn chút nữa.
Điển hình:
Dim sArr As Variant, dArr(1 To 500000, 1 To 135)
sArr: 170000x12 = 2040000 phần tử
dArr: 500000x135 = 67,5 triệu phần tử

truongvu317 · 27/7/18

tueyennhi đã viết:

Đoạn code dưới đây em dùng để xử lý dữ liệu có 170.000 dòng và 12 cột.
Dữ liệu nguồn dạng dọc (dữ liệu có 170.000 dòng và 12 cột)
Dữ liệu đíc em muốn chuyển thành dạng ngang (Dữ liệu đíc có 125 cột)
Nhưng máy em khi chạy báo Out of memory. Cho em hỏi các biến của em trong code này đã đúng hay chưa?

PHP:

Public Sub BCC_erp()
    Dim Dic As Object, Col As Object, Ws As Worksheet, Tem As String, Tem1 As String, Rws As Long
    Dim R As Long, i As Long, j As Long, K As Long, C As Long, H As Long
    Dim sArr As Variant, dArr(1 To 500000, 1 To 135)
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Col = CreateObject("Scripting.Dictionary")
    With Application
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With
    K = 0
    C = 0
    With Sheets("BCC")
        If CStr(.Range("H8")) <> "" Then
            .Range("J8:FD" & .Range("J" & Rows.Count).End(xlUp).Row).Clear
        End If
        sArr = .Range("J2").Resize(6, 125).Value
        For j = 2 To 125
            If sArr(1, j) <> Empty Then
                If IsDate(sArr(1, j)) Then
                    Col.Item(Day(sArr(1, j)) & sArr(6, j)) = j
                End If
            End If
        Next j
        '...............Dinh dang mau ngay chu nhat........................'
        For j = 12 To 132 Step 4
            If .Cells(6, j).Value Like "Sunday" Then
                .Cells(6, j).Offset(-2, -1).Resize(1, 4).Interior.Color = 49407
            Else
                .Cells(6, j).Offset(-2, -1).Resize(1, 4).Interior.Color = xlNone
            End If
        Next j
    End With
    With Sheets("Data2")
        sArr = .Range("A5", .Range("A300000").End(xlUp)).Resize(, 12).Value
        R = UBound(sArr, 1)
        For i = 1 To R
                Tem1 = Day(sArr(i, 1)) & sArr(i, 12)
                If Col.Exists(Tem1) Then
                    C = Col.Item(Tem1)
                    Tem = sArr(i, 2)
                    If Len(sArr(i, 2)) = 5 Then
                        If Not Dic.Exists(Tem) Then
                            K = K + 1
                            Dic.Add Tem, K
                            dArr(K, 1) = sArr(i, 2)
                        End If
                        Rws = Dic.Item(Tem)
                        dArr(Rws, C) = dArr(Rws, C) + sArr(i, 11)
                    End If
                End If
        Next i
    End With
    With Sheets("BCC")
        If K Then
            .Range("J8").Resize(K, 125) = dArr
            .Range("A4").Resize(, 162).Copy
            .Range("A8").Resize(K, 162).PasteSpecial Paste:=xlPasteFormats
            .Rows(K + 8 & ":" & K + 5000).Clear
        End If
    End With
    Set Dic = Nothing
    Set Col = Nothing
    With Application
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With
End Sub

Em đã đọc đi đoc lại về trường hợp gần tương tự của em trong chủ đề này
https://www.giaiphapexcel.com/diendan/threads/lối-out-of-memory.79903/
Nhưng em không hiểu cần sửa đổi code như thế nào cho phải. Dữ liệu trong mảng của em có cả dạng số và chữ. Mặc dù dữ liệu gốc là 170.000 dòng nhưng khi tổng hợp nếu thành công thì chỉ còn hơn 3000 dòng mà thôi. Rất mong mọi người giúp em. .
Em cảm ơn!

Bạn này qua lại trên gpe nhiều, mà vẫn mắc phải những lỗi nhi đồng ý, cái gì thì cũng là file đâu. Bảo sao hàng tá các thành viên hay mắc phải nội quy.

tueyennhi · 27/7/18

VetMini đã viết:
Cần đọc kỹ hơn chút nữa.
Điển hình:
Dim sArr As Variant, dArr(1 To 500000, 1 To 135)
sArr: 170000x12 = 2040000 phần tử
dArr: 500000x135 = 67,5 triệu phần tử

Thưa anh cho em hỏi, trong code của em sử dụng dic vì có nhiều mã trùng lặp lại. Nếu trùng em sẽ cộng hai kết quả mã trùng đó với nhau. Như vậy lần trùng đó có được coi là tốn mất 1 phần tử không hay do nó phát hiện trùng nó sẽ gán vào phần tử có mã trùng đó nên nó sẽ không tính là đã bị tiêu tốn đi 1 phần tử? Kết quả dArr của em chắc chắn chỉ có 3000 dòng và 135 cột vậy thì em khai báo lại
darr( 1 to 3000, 1 to 135) có được không anh? Vì khi em khai báo như vậy nó phát sinh lỗi khác (Run time erro 13 Type missing)

Em kiểm tra trong cửa sổ Local, thông số cuối cùng của darr thì thấy Empty nên em nghĩ không phải do mảng darr của em thiếu.

tueyennhi · 27/7/18

VetMini đã viết:
Cần đọc kỹ hơn chút nữa.
Điển hình:
Dim sArr As Variant, dArr(1 To 500000, 1 To 135)
sArr: 170000x12 = 2040000 phần tử
dArr: 500000x135 = 67,5 triệu phần tử

Anh ơi em thay đổi lại các cột không cần thiết của mảng sArr giảm 12 cột xuống 5 cột đã chạy rồi anh ạ. Có vẻ em đã hiểu vấn đề. Cảm ơn anh rất nhiều!

Bài đã được tự động gộp: 27/7/18

truongvu317 đã viết:
Bạn này qua lại trên gpe nhiều, mà vẫn mắc phải những lỗi nhi đồng ý, cái gì thì cũng là file đâu. Bảo sao hàng tá các thành viên hay mắc phải nội quy.

Lỗi của em là gặp đâu đánh đó không hiểu bản chất, không có căn bản. File của em rất nặng nên không post lên được. Em đã giải quyết được vấn đề rồi. Cảm ơn mọi người!

nhatquyelec · 1/8/18

Chào mọi người,
Mình có một vấn đề này mong mọi người giúp đỡ,
Mình dùng macro để ghi lại các thao tác và tạo một nút sau đó copy đoạn code từ marco đó dán vào nút.
Sau đó ấn nút nhưng nó không chạy nơi, mong mọi người chỉ dẫn

aduc · 2/8/18

nhatquyelec đã viết:
Chào mọi người,
Mình có một vấn đề này mong mọi người giúp đỡ,
Mình dùng macro để ghi lại các thao tác và tạo một nút sau đó copy đoạn code từ marco đó dán vào nút.
Sau đó ấn nút nhưng nó không chạy nơi, mong mọi người chỉ dẫn

Bạn chuyển code sang module, tạo một nút bằng trình điều khiển Form nhé, không dùng active X.Đặt lại sub tên khác, không để chế độ private
Ví dụ Sub abc()
Code here ......
End sub
Gán sub abc vào cho nút vừa tạo và chạy nhé.
Chúc thành công!
( Nội dung code mình chưa có thời gian xem)

aduc · 2/8/18

Mình có đoạn code như sau:

PHP:

Sub PTVT()
Call Code_Begin
Dim i, endR1, endR2 As Long
Dim j, d As Long
Dim Num_CV, numtg As Long
endR1 = shTL.Range("B" & Rows.Count).End(xlUp).row
endR2 = shPTVT.Range("C" & Rows.Count).End(xlUp).row
Num_CV = WorksheetFunction.CountA(shTL.Range("A7:A" & endR1 - 1))
shPTVT.Activate
' Xoa du lieu bang truoc khi phan tich .....
    'Rows("5:5").AutoFilter
    If endR2 > 6 Then
    shPTVT.Rows(6 & ":" & endR2).Select
    shPTVT.Range("B6").Activate
    Selection.Delete Shift:=xlUp
    End If
' Copy Template phan tich vat tu............
    Sheets("PTVT(Temp)").Range("A6:P169").Copy Destination:=Sheets("PTVT").Range("A6")
' Tao danh sach cong viec
ReDim arrcv(0 To Num_CV - 1, 0 To 4)
d = 0
    For j = 7 To endR1 - 1
                If shTL.Range("A" & j) <> "" Then
                    arrcv(d, 0) = shTL.Range("A" & j).Value
                    arrcv(d, 1) = "='Tien luong'!B" & j
                    arrcv(d, 2) = "='Tien luong'!C" & j
                    arrcv(d, 3) = "='Tien luong'!D" & j
                    arrcv(d, 4) = "='Tien luong'!L" & j
                    d = d + 1
                End If
    Next j

' Copy theo so cong viec hien tai
    shPTVT.Range("A6:P" & 169).Select
    Selection.Copy
For i = 0 To Num_CV - 1
    shPTVT.Range("A" & 6 + 164 * i).Select
    ActiveSheet.Paste
                    shPTVT.Range("B" & 6 + 164 * (i)).Value = arrcv(i, 0)
                    shPTVT.Range("C" & 6 + 164 * (i)).Formula = arrcv(i, 1)
                    shPTVT.Range("E" & 6 + 164 * (i)).Formula = arrcv(i, 2)
                    shPTVT.Range("F" & 6 + 164 * (i)).Formula = arrcv(i, 3)
                    shPTVT.Range("G" & 6 + 164 * (i)).Formula = arrcv(i, 4)
Next i
Call Code_End
' Xoa dong trang.........................
    endR2 = shPTVT.Range("C" & Rows.Count).End(xlUp).row
    ActiveSheet.Range("$A$5:$O$" & endR2).AutoFilter Field:=3, Criteria1:="="
    Rows(7 & ":" & endR2).Select
    Rows(6 & ":" & endR2).EntireRow.Delete
' 'Filter lai
    ActiveSheet.ShowAllData
    ActiveSheet.Range("A1").Select
End Sub

Mục đích: Copy dữ liệu từ một bảng tính mẫu, sau đó tùy theo số công việc từ shTL, copy bảng mẫu đó theo số công việc.
Sau khi phân tích thì xóa các dòng không có dữ liệu.
Vấn đề là tốc độ chạy code hơi chậm, các bác xem code có đoạn nào gây chiếm bộ nhớ không.
Có cách nào tăng tốc code không.
Mình đã sử dụng các cách tăng tốc code thông thường rồi.

♫ђöล♥ßล†♥†µ♫ · 2/8/18

aduc đã viết:

Mình có đoạn code như sau:

PHP:

Sub PTVT()
Call Code_Begin
Dim i, endR1, endR2 As Long
Dim j, d As Long
Dim Num_CV, numtg As Long
endR1 = shTL.Range("B" & Rows.Count).End(xlUp).row
endR2 = shPTVT.Range("C" & Rows.Count).End(xlUp).row
Num_CV = WorksheetFunction.CountA(shTL.Range("A7:A" & endR1 - 1))
shPTVT.Activate
' Xoa du lieu bang truoc khi phan tich .....
    'Rows("5:5").AutoFilter
    If endR2 > 6 Then
    shPTVT.Rows(6 & ":" & endR2).Select
    shPTVT.Range("B6").Activate
    Selection.Delete Shift:=xlUp
    End If
' Copy Template phan tich vat tu............
    Sheets("PTVT(Temp)").Range("A6:P169").Copy Destination:=Sheets("PTVT").Range("A6")
' Tao danh sach cong viec
ReDim arrcv(0 To Num_CV - 1, 0 To 4)
d = 0
    For j = 7 To endR1 - 1
                If shTL.Range("A" & j) <> "" Then
                    arrcv(d, 0) = shTL.Range("A" & j).Value
                    arrcv(d, 1) = "='Tien luong'!B" & j
                    arrcv(d, 2) = "='Tien luong'!C" & j
                    arrcv(d, 3) = "='Tien luong'!D" & j
                    arrcv(d, 4) = "='Tien luong'!L" & j
                    d = d + 1
                End If
    Next j

' Copy theo so cong viec hien tai
    shPTVT.Range("A6:P" & 169).Select
    Selection.Copy
For i = 0 To Num_CV - 1
    shPTVT.Range("A" & 6 + 164 * i).Select
    ActiveSheet.Paste
                    shPTVT.Range("B" & 6 + 164 * (i)).Value = arrcv(i, 0)
                    shPTVT.Range("C" & 6 + 164 * (i)).Formula = arrcv(i, 1)
                    shPTVT.Range("E" & 6 + 164 * (i)).Formula = arrcv(i, 2)
                    shPTVT.Range("F" & 6 + 164 * (i)).Formula = arrcv(i, 3)
                    shPTVT.Range("G" & 6 + 164 * (i)).Formula = arrcv(i, 4)
Next i
Call Code_End
' Xoa dong trang.........................
    endR2 = shPTVT.Range("C" & Rows.Count).End(xlUp).row
    ActiveSheet.Range("$A$5:$O$" & endR2).AutoFilter Field:=3, Criteria1:="="
    Rows(7 & ":" & endR2).Select
    Rows(6 & ":" & endR2).EntireRow.Delete
' 'Filter lai
    ActiveSheet.ShowAllData
    ActiveSheet.Range("A1").Select
End Sub

Mục đích: Copy dữ liệu từ một bảng tính mẫu, sau đó tùy theo số công việc từ shTL, copy bảng mẫu đó theo số công việc.
Sau khi phân tích thì xóa các dòng không có dữ liệu.
Vấn đề là tốc độ chạy code hơi chậm, các bác xem code có đoạn nào gây chiếm bộ nhớ không.
Có cách nào tăng tốc code không.
Mình đã sử dụng các cách tăng tốc code thông thường rồi.

Mình ơi. Sao mình không đính kèm file thì ai biết đâu mà lần. Ai biết cái Code_Begin nó là cái chi chi

Ba Tê · 2/8/18

aduc đã viết:

Mình có đoạn code như sau:

PHP:

Sub PTVT()
Call Code_Begin
Dim i, endR1, endR2 As Long
Dim j, d As Long
Dim Num_CV, numtg As Long
endR1 = shTL.Range("B" & Rows.Count).End(xlUp).row
endR2 = shPTVT.Range("C" & Rows.Count).End(xlUp).row
Num_CV = WorksheetFunction.CountA(shTL.Range("A7:A" & endR1 - 1))
shPTVT.Activate
' Xoa du lieu bang truoc khi phan tich .....
    'Rows("5:5").AutoFilter
    If endR2 > 6 Then
    shPTVT.Rows(6 & ":" & endR2).Select
    shPTVT.Range("B6").Activate
    Selection.Delete Shift:=xlUp
    End If
' Copy Template phan tich vat tu............
    Sheets("PTVT(Temp)").Range("A6:P169").Copy Destination:=Sheets("PTVT").Range("A6")
' Tao danh sach cong viec
ReDim arrcv(0 To Num_CV - 1, 0 To 4)
d = 0
    For j = 7 To endR1 - 1
                If shTL.Range("A" & j) <> "" Then
                    arrcv(d, 0) = shTL.Range("A" & j).Value
                    arrcv(d, 1) = "='Tien luong'!B" & j
                    arrcv(d, 2) = "='Tien luong'!C" & j
                    arrcv(d, 3) = "='Tien luong'!D" & j
                    arrcv(d, 4) = "='Tien luong'!L" & j
                    d = d + 1
                End If
    Next j

' Copy theo so cong viec hien tai
    shPTVT.Range("A6:P" & 169).Select
    Selection.Copy
For i = 0 To Num_CV - 1
    shPTVT.Range("A" & 6 + 164 * i).Select
    ActiveSheet.Paste
                    shPTVT.Range("B" & 6 + 164 * (i)).Value = arrcv(i, 0)
                    shPTVT.Range("C" & 6 + 164 * (i)).Formula = arrcv(i, 1)
                    shPTVT.Range("E" & 6 + 164 * (i)).Formula = arrcv(i, 2)
                    shPTVT.Range("F" & 6 + 164 * (i)).Formula = arrcv(i, 3)
                    shPTVT.Range("G" & 6 + 164 * (i)).Formula = arrcv(i, 4)
Next i
Call Code_End
' Xoa dong trang.........................
    endR2 = shPTVT.Range("C" & Rows.Count).End(xlUp).row
    ActiveSheet.Range("$A$5:$O$" & endR2).AutoFilter Field:=3, Criteria1:="="
    Rows(7 & ":" & endR2).Select
    Rows(6 & ":" & endR2).EntireRow.Delete
' 'Filter lai
    ActiveSheet.ShowAllData
    ActiveSheet.Range("A1").Select
End Sub

Mục đích: Copy dữ liệu từ một bảng tính mẫu, sau đó tùy theo số công việc từ shTL, copy bảng mẫu đó theo số công việc.
Sau khi phân tích thì xóa các dòng không có dữ liệu.
Vấn đề là tốc độ chạy code hơi chậm, các bác xem code có đoạn nào gây chiếm bộ nhớ không.
Có cách nào tăng tốc code không.
Mình đã sử dụng các cách tăng tốc code thông thường rồi.

Sao bạn không đưa file có code lên, nói rõ kết quả ... (đúng nhưng chậm... hay gì đó ) thì người khác mới hiểu được bạn muốn gì.
Bạn đưa code như thế, đọc từng dòng rồi "ngó lên trời" một hồi mới hiểu bạn viết cái gì, 1 trăm dòng phải "ngó lên trời" 100 lần ... gãy cổ thôi.

aduc · 2/8/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Mình ơi. Sao mình không đính kèm file thì ai biết đâu mà lần. Ai biết cái Code_Begin nó là cái chi chi

Code_begin và Code_end chỉ là tắt chế độ màn hình và chế độ tính toán tự động thôi bác.
Code chạy bình thường nhưng tốc độ chậm.
Mình muốn hỏi là với nội dung đó có cách nào cải thiện tốc độ hơn không.
Thanks bác.

Bài đã được tự động gộp: 2/8/18

Ba Tê đã viết:
Sao bạn không đưa file có code lên, nói rõ kết quả ... (đúng nhưng chậm... hay gì đó ) thì người khác mới hiểu được bạn muốn gì.
Bạn đưa code như thế, đọc từng dòng rồi "ngó lên trời" một hồi mới hiểu bạn viết cái gì, 1 trăm dòng phải "ngó lên trời" 100 lần ... gãy cổ thôi.

Mình có nói rõ là code chạy được nhưng chậm. Không biết có chỗ nào chưa tối ưu không thôi bạn.

ndu96081631 · 2/8/18

aduc đã viết:
Mình có nói rõ là code chạy được nhưng chậm. Không biết có chỗ nào chưa tối ưu không thôi bạn.

Code gán trực tiếp từng cell đương nhiên phải chậm rồi. Muốn nhanh phải dùng mảng
Thấy bạn viết quá trời phần mềm, sao hỏi mấy chuyện đơn giản này nhỉ?

aduc · 2/8/18

ndu96081631 đã viết:
Code gán trực tiếp từng cell đương nhiên phải chậm rồi. Muốn nhanh phải dùng mảng
Thấy bạn viết quá trời phần mềm, sao hỏi mấy chuyện đơn giản này nhỉ?

Vấn đề là cells mình chứa công thức để xử lý, nên không dùng mảng không tiện. Hix

♫ђöล♥ßล†♥†µ♫ · 2/8/18

aduc đã viết:
Vấn đề là cells mình chứa công thức để xử lý, nên không dùng mảng được. Hix

Ai bẩu Bác là mảng không dùng được công thức. Quan trong là Bác dùng thuộc tính gì của nó thôi

aduc · 2/8/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Ai bẩu Bác là mảng không dùng được công thức. Quan trong là Bác dùng thuộc tính gì của nó thôi

Ví dụ mình có 1 mảng từ Range("A1

100"), mỗi cell chứa 1 công thức excel, làm sao để gán mảng mà khi trả về vẫn trả công thức, không phải giá trị.....

♫ђöล♥ßล†♥†µ♫ · 2/8/18

aduc đã viết:
Ví dụ mình có 1 mảng từ Range("A1100"), mỗi cell chứa 1 công thức excel, làm sao để gán mảng mà khi trả về vẫn trả công thức, không phải giá trị.....

Bác thử xem file đính kèm xem nó trả về cái gì nha

aduc · 2/8/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Bác thử xem file đính kèm xem nó trả về cái gì nha

Đúng là mình đã từng nghĩ về nó nhưng chưa thử, theo bạn việc gán Arr so với copy trực tiếp từ Excel có ổn hơn ko, Theo code trên thì mình copy vùng A6

169, dán vào ô A170 và cứ thế dán vào các ô dưới đó theo số công việc.
Thanks nhiều.

♫ђöล♥ßล†♥†µ♫ · 2/8/18

aduc đã viết:
Đúng là mình đã từng nghĩ về nó nhưng chưa thử, theo bạn việc gán Arr so với copy trực tiếp từ Excel có ổn hơn ko, Theo code trên thì mình copy vùng A6169, dán vào ô A170 và cứ thế dán vào các ô dưới đó theo số công việc.
Cảm ơn nhiều.

Mảng bao giờ cũng nhanh hơn là làm trực tiếp trên cells. Thầy Ba tê và Thầy ndu96081631 là Bậc Thầy về mảng của diễn đàn. Với bài của Bác đưa file Demo thì bây giờ xong lâu rồi

aduc · 2/8/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Mảng bao giờ cũng nhanh hơn là làm trực tiếp trên cells. Thầy Ba tê và Thầy ndu96081631 là Bậc Thầy về mảng của diễn đàn. Với bài của Bác đưa file Demo thì bây giờ xong lâu rồi

Mình sẽ thử chuyển đổi dùng mảng thay vì copy paste, vì thấy tốc độ paste bình thường cũng nhanh nên ko nghĩ đến. THanks bạn nhiều

aduc · 2/8/18

aduc đã viết:
Mình sẽ thử chuyển đổi dùng mảng thay vì copy paste, vì thấy tốc độ paste bình thường cũng nhanh nên ko nghĩ đến. Cảm ơn bạn nhiều

Mình đã định thử nhưng vấn đề là mình copy vùng dữ liệu chứa cả định dạng và công thức, trong công thức có cả tham chiếu tuyệt đối và tương đối, việc copy cả vùng vẫn là lựa chọn tối ưu theo mình nghĩ vậy. Vì khi gán mảng, có một số vấn đề xảy ra như:
- Mình định dạng dấu ";" nhưng công thức trả về định dạng dấu","
- Mất định dạng cell, font chữ ...

Hau151978 · 2/8/18

aduc đã viết:
Mình đã định thử nhưng vấn đề là mình copy vùng dữ liệu chứa cả định dạng và công thức, trong công thức có cả tham chiếu tuyệt đối và tương đối, việc copy cả vùng vẫn là lựa chọn tối ưu theo mình nghĩ vậy. Vì khi gán mảng, có một số vấn đề xảy ra như:
- Mình định dạng dấu ";" nhưng công thức trả về định dạng dấu","
- Mất định dạng cell, font chữ ......

Bạn định dạng trước vùng cần dán dữ liệu vào. Công thức nếu bạn muốn copy có cả tham chiếu tương đối và muốn công thức thay đổi theo tham chiếu đó thì dùng property FormulaR1C1. Ví dụ: công thức cột A là A1=C1+1, sau khi chạy code ở dưới thì ở cột B sẽ có công thức B1=D1+1:
Dim arr()
arr=range("A1:A10").FormulaR1C1
Range("B1:B10")=arr

aduc · 2/8/18

Hau151978 đã viết:
Bạn định dạng trước vùng cần dán dữ liệu vào. Công thức nếu bạn muốn copy có cả tham chiếu tương đối thì dùng property FormulaR1C1. Ví dụ:
Dim arr()
arr=range("A1:A10").FormulaR1C1
Range("B1:B10")=arr

Cảm ơn bạn, vấn đề là định dạng từng ô nữa. Mình có gửi file đó, các bạn có thời gian nghiên cứu với.

Hau151978 · 2/8/18

aduc đã viết:
Cảm ơn bạn, vấn đề là định dạng từng ô nữa. Mình có gửi file đó, các bạn có thời gian nghiên cứu với.

Định dạng ô bạn nên làm từ đầu, trước khi chạy code copy. File của bạn mình không hiểu được nên chỉ có ý kiến đóng góp thôi.

aduc · 2/8/18

Hau151978 đã viết:
Định dạng ô bạn nên làm từ đầu, trước khi chạy code copy.

Mình đã làm thế, quan trọng là code chạy chậm, vấn đề là khắc phục tốc độ thôi. Bạn có thể tải file để nghiên cứu nhé

ndu96081631 · 2/8/18

aduc đã viết:
Mình đã làm thế, quan trọng là code chạy chậm, vấn đề là khắc phục tốc độ thôi. Bạn có thể tải file để nghiên cứu nhé

Mọi người làm việc trên Excel ai cũng biết rằng:
- Code gán trực tiếp trên cell luôn chậm hơn xử lý mảng
- Đã dùng code, thường người ta sẽ dẹp hết công thức. Tính toán mọi thứ trong code rồi gán 1 lần
- Định dạng là tác nhân gây ra chậm + dung lượng file lớn
Tất cả những cái đó, bạn dính đủ. Vậy phải làm gì, tự bạn quyết định

tnfsmith · 3/8/18

C#:

Sub scriptingdictionary()
Dim arrdata() As Variant, result() As Variant
Dim i As Long, j As Long, k As Long
arrdata = Range("A1:M" & Range("A" & Rows.Count).End(xlUp).Row).Value
ReDim result(i = LBound(arrdata, 1) To UBound(arrdata, 1), 1 To 5)
With CreateObject("Scripting.Dictionary")
    For i = LBound(arrdata, 1) To UBound(arrdata, 1)
      
        If Not .Exists(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)) Then
        k = k + 1
        .Add arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11), k
            For j = 1 To 5
        result(k, j) = arrdata(i, j)
            Next j
        result(k, 1) = arrdata(i, 1)
        result(k, 2) = arrdata(i, 2)
        result(k, 3) = arrdata(i, 3)
        result(k, 4) = arrdata(i, 11)
        result(k, 5) = arrdata(i, 13)
    
        Else
        result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) = result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) + arrdata(i, 13)
      
        End If

    Next i
End With
With Sheet2

.Range("A1").Resize(100000, 5).ClearContents
.Range("A1").Resize(k, 5) = result
End With
End Sub

Ae cho mình hỏi cái code trên ra kết quả ở Sheet2 lúc nào cũng dư một row trên cùng của kết quả, đồng thời ở dòng cuối cùng của kết quả lại thiếu một dòng so với sheet1 (chứa arrdata). Mình tinh chỉnh mãi mà ko hiệu quả
Thanks anh em nhiều

phulien1902 · 3/8/18

tnfsmith đã viết:

C#:

Sub scriptingdictionary()
Dim arrdata() As Variant, result() As Variant
Dim i As Long, j As Long, k As Long
arrdata = Range("A1:M" & Range("A" & Rows.Count).End(xlUp).Row).Value
ReDim result(i = LBound(arrdata, 1) To UBound(arrdata, 1), 1 To 5)
With CreateObject("Scripting.Dictionary")
    For i = LBound(arrdata, 1) To UBound(arrdata, 1)
      
        If Not .Exists(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)) Then
        k = k + 1
        .Add arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11), k
            For j = 1 To 5
        result(k, j) = arrdata(i, j)
            Next j
        result(k, 1) = arrdata(i, 1)
        result(k, 2) = arrdata(i, 2)
        result(k, 3) = arrdata(i, 3)
        result(k, 4) = arrdata(i, 11)
        result(k, 5) = arrdata(i, 13)
    
        Else
        result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) = result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) + arrdata(i, 13)
      
        End If

    Next i
End With
With Sheet2

.Range("A1").Resize(100000, 5).ClearContents
.Range("A1").Resize(k, 5) = result
End With
End Sub

Ae cho mình hỏi cái code trên ra kết quả ở Sheet2 lúc nào cũng dư một row trên cùng của kết quả, đồng thời ở dòng cuối cùng của kết quả lại thiếu một dòng so với sheet1 (chứa arrdata). Mình tinh chỉnh mãi mà ko hiệu quả
Cảm ơn anh em nhiều

Thử:

PHP:

Option Explicit
Sub scriptingdictionary()
    Dim arrdata() As Variant, result() As Variant
    Dim i As Long, j As Long, k As Long
    arrdata = Range("A2:M" & Range("A" & Rows.Count).End(xlUp).Row).Value
    'ReDim result(i = LBound(arrdata, 1) To UBound(arrdata, 1), 1 To 5)
    ReDim result(1 To UBound(arrdata, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        For i = LBound(arrdata, 1) To UBound(arrdata, 1)
            If Not .Exists(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)) Then
                k = k + 1
                .Add arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11), k
                For j = 1 To 5
                    result(k, j) = arrdata(i, j)
                Next j
                result(k, 1) = arrdata(i, 1)
                result(k, 2) = arrdata(i, 2)
                result(k, 3) = arrdata(i, 3)
                result(k, 4) = arrdata(i, 11)
                result(k, 5) = arrdata(i, 13)
            Else
                result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) = result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) + arrdata(i, 13)
            End If
        Next i
    End With
    With Sheet2
        .Range("A2").Resize(1000, 5).ClearContents
        .Range("A2").Resize(k, 5) = result
    End With
End Sub

♫ђöล♥ßล†♥†µ♫ · 3/8/18

phulien1902 đã viết:

Thử:

PHP:

Option Explicit
Sub scriptingdictionary()
    Dim arrdata() As Variant, result() As Variant
    Dim i As Long, j As Long, k As Long
    arrdata = Range("A2:M" & Range("A" & Rows.Count).End(xlUp).Row).Value
    'ReDim result(i = LBound(arrdata, 1) To UBound(arrdata, 1), 1 To 5)
    ReDim result(1 To UBound(arrdata, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        For i = LBound(arrdata, 1) To UBound(arrdata, 1)
            If Not .Exists(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)) Then
                k = k + 1
                .Add arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11), k
                For j = 1 To 5
                    result(k, j) = arrdata(i, j)
                Next j
                result(k, 1) = arrdata(i, 1)
                result(k, 2) = arrdata(i, 2)
                result(k, 3) = arrdata(i, 3)
                result(k, 4) = arrdata(i, 11)
                result(k, 5) = arrdata(i, 13)
            Else
                result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) = result(.Item(arrdata(i, 1) & arrdata(i, 3) & arrdata(i, 11)), 5) + arrdata(i, 13)
            End If
        Next i
    End With
    With Sheet2
        .Range("A2").Resize(1000, 5).ClearContents
        .Range("A2").Resize(k, 5) = result
    End With
End Sub

Khiếp. Em cứ ngóc lên ngóc xuống xem các câu lệnh vẫn không thấy gì khác. Mãi mới thấy khác là A1 và A2. Mỏi hết cả cổ Anh ạ

phulien1902 · 3/8/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Khiếp. Em cứ ngóc lên ngóc xuống xem các câu lệnh vẫn không thấy gì khác. Mãi mới thấy khác là A1 và A2. Mỏi hết cả cổ Anh ạ

Khác chỗ này nè:

PHP:

   ReDim result(i = LBound(arrdata, 1) To UBound(arrdata, 1), 1 To 5)

thành:

PHP:

    ReDim result(1 To UBound(arrdata, 1), 1 To 5)

be_09 · 3/8/18

aduc đã viết:
Mình có đoạn code như sau:
Sub PTVT()
Call Code_Begin
Call Code_End
................................
Có cách nào tăng tốc code không.........................

1/ Code_begin và Code_end chỉ là tắt chế độ màn hình và chế độ tính toán tự động sao không cho nó chung vào một.
2/ Thay vì sử dụng AutoFilter sao không dùng Advanced Filter nó cũng có chức năng Filter.
3/ Trong code mà sử dụng Select và ActiveSheet nên nó chậm là phải rồi.

aduc · 4/8/18

be09 đã viết:
1/ Code_begin và Code_end chỉ là tắt chế độ màn hình và chế độ tính toán tự động sao không cho nó chung vào một.
2/ Thay vì sử dụng AutoFilter sao không dùng Advanced Filter nó cũng có chức năng Filter.
3/ Trong code mà sử dụng Select và ActiveSheet nên nó chậm là phải rồi.

Call Code_Begin: để tắt các chức năng
Call Code_End: Để bật trở lại

Lequocvan · 8/8/18

Em đang phải học lại dictionary nên đoạn code sau chưa hiểu, chưa biết làm như thế nào để tính tổng theo code duy nhất ah. Mong Thầy chỉ giúp!

Sub T2()
Worksheets("Data").Range("F2", Range("I65536").End(xlUp)).Select
Selection.ClearContents
Range("F1").Select
Range("F1").Value = "GtriDuynhatCode"
Range("G1").Value = "Product_Gom"
Range("H1").Value = "TongTheoCode"
Range("I1").Value = "count"

Dim dic As Object, dic2 As Object
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")

Dim Arr As Variant
Dim VungDuLieu
Set VungDuLieu = Worksheets("Data").Range("A2", Range("C65536").End(xlUp))
Arr = VungDuLieu.Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 3)

Dim iRow As Long, i As Long, j As Long
For iRow = 1 To UBound(Arr, 1)
If Not IsEmpty(Arr(iRow, 1)) And Not dic.Exists(Arr(iRow, 1)) Then
i = i + 1
dic.Add Key:=Arr(iRow, 1), Item:=i

dArr(i, 1) = Arr(iRow, 1)

'MsgBox "iTems " & dic.Count & " cua dic " & " tai dong thu: " & (iRow + 1) _
' & "___" & Arr(iRow, 1) & "___" & Arr(iRow, 2) _
' & "___" & Arr(iRow, 3)

'MsgBox dic.Count & vbCrLf & Join(dic.keys, vbLf) 'Cau lenh rat hay ve dictionary
'MsgBox dic.Count & vbCrLf & Join(dic.Keys, vbLf) & vbCrLf _
' & vbCrLf & (iRow + 1) & "___" _
' & "___" & Arr(iRow, 2) _
' & "___" & Arr(iRow, 3)
' 'Arr(iRow, 1)~Join(dic.keys, vbLf)
'MsgBox UBound(dic.Keys) + 1 'So luong gia tri duy nhat Keys

Else
'MsgBox UBound(dic.Items) + 1
End If
Next

'Tra ket qua
Range("F2").Resize(i, 4).Value = dArr
Range("F1").Select

'MsgBox "So luong iTems la: " & dic.Count
Set dic = Nothing
Set dic2 = Nothing
'MsgBox "Done"
End Sub

Ba Tê · 8/8/18

Lequocvan đã viết:
Em đang phải học lại dictionary nên đoạn code sau chưa hiểu, chưa biết làm như thế nào để tính tổng theo code duy nhất ah. Mong Thầy chỉ giúp!

Tổng theo Code duy nhất hay theo Code+Product duy nhất?
Nếu theo Code+Product duy nhất thì xem cái này.

PHP:

Sub s_Gpe()
Application.ScreenUpdating = False
Dim Dic As Object, Tem As String
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Range("A2", Range("C65536").End(xlUp))
    Rws = UBound(sArr)
ReDim dArr(1 To Rws, 1 To 4)
dArr(1, 1) = "GtriDuynhatCode"
dArr(1, 2) = "Product_Gom"
dArr(1, 3) = "TongTheoCode"
dArr(1, 4) = "Count"
K = 1
For I = 1 To Rws
    Tem = sArr(I, 1) & "#" & sArr(I, 2)
    If Not Dic.Exists(Tem) Then
        K = K + 1
        Dic.Item(Tem) = K
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
        dArr(K, 4) = 1
    Else
        R = Dic.Item(Tem)
        dArr(R, 3) = dArr(R, 3) + sArr(I, 3)
        dArr(R, 4) = dArr(R, 4) + 1
    End If
Next I
Range("F1:I1").Resize(K) = dArr
Range("F2:I2").Resize(K).Sort Key1:=Range("F2"), Key2:=Range("G2")
Set Dic = Nothing
End Sub

Lequocvan · 8/8/18

Tuyệt vời! code này em phải vọc thật kỹ mới được! quá hay luôn ấy!
Nếu chỉ tính tổng theo code duy nhất thì ntn ah?

Chuyên đề giải đáp những thắc mắc về code VBA (9 người xem)

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

Thành viên thường trực

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

File đính kèm

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

File đính kèm

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

Thành viên tiêu biểu

Thành viên tiêu biểu

Thành viên tiêu biểu

Đang đi tìm hòn đá

Thành viên mới

File đính kèm

Thành viên mới

File đính kèm

GPE - My love

Thành viên mới

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

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

File đính kèm

/(hông là gì!

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

File đính kèm

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

|||||||||||||

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

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

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

Thành viên tiêu biểu

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

Thành viên tiêu biểu

Huyền thoại GPE

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

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

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

Thành viên mới

GPE là ngôi nhà thứ 2 của tôi!!!

|||||||||||||

Thành viên mới

Huyền thoại GPE

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

File đính kèm

Chuyên gia GPE

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

Thành viên mới

Huyền thoại GPE

Thành viên tiêu biểu

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

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

Chuyên gia GPE

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

Đang đi tìm hòn đá

Thành viên mới

File đính kèm

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

Thành viên mới

Huyền thoại GPE

Thành viên mới

Thành viên mới

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

Thành viên mới

Thành viên thường trực

Thành viên thường trực

Huyền thoại GPE

==(^o^)==

Thành viên thường trực

Thành viên mới

File đính kèm

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

Thành viên mới

==(^o^)==

Thành viên mới

File đính kèm

Biên Hòa, Đồng Nai

Đang đi tìm hòn đá

Thành viên mới