Chuyên đề giải đáp những thắc mắc về code VBA

Liên hệ QC

maytinhvp01

Thành viên thường trực
Tham gia
27/7/13
Bài viết
390
Được thích
179
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]
 
Chỉnh sửa lần cuối bởi điều hành viên:
Xin chào cả nhà, trong file quản lý thư viện mình số lượng tồn kho trong sheet Tonkho (Dựa vào sheet Sach vs sheet Sachmuon) theo code như này (Vừa sao chép dữ liệu không trùng và dùm countif để tính tồn kho)

Mã:
Sub Tonkhosach()
Application.ScreenUpdating = False
' Macro6 Macro
Sheet14.Range("$B$5:CB$65000").Clear
    Sheet3.Range("D6:D65000").Copy
     Sheet14.Range("B5").PasteSpecial Paste:=xlPasteValues
    
Sheet14.Range("B5:B" & 65000).RemoveDuplicates Columns:=1, Header:=xlNo
      
    
    With Sheet14.Range("B4:C10000").Font
         .Name = "Times New Roman"
        .Size = 10
    End With
  
    'tinhtonkho
    
    Sheet14.Activate
   Dim i As Long
    i = 5
    Do While Sheet14.Cells(i, 2) <> ""
    With Sheet14
    .Cells(i, 3) = Application.WorksheetFunction.CountIfs(Sheet3.Range("D1:D65000"), .Cells(i, 2)) - Application.WorksheetFunction.CountIfs(Sheet6.Range("G1:G65000"), .Cells(i, 2), Sheet6.Range("K1:K65000"), "Muon")
    End With
    i = i + 1
    Loop
Dim dctonkho As Long
dctonkho = Sheet14.Range("B65000").End(xlUp).Row
Range("A4:C65000").Borders.LineStyle = 0
Range("A4:C" & dctonkho).Borders.LineStyle = 1
Sheet14.Range("A4").Select

MsgBox ("Da Cap Nhat Xong")
Application.ScreenUpdating = True
 End Sub

Nhưng khi chạy code nó chạy rất lâu.

217218

Không biết mình có làm sai chỗ nào ko, hay do dữ liệu tính toán nhiều? (Khoảng 3000 dòng). Anh em chỉ giúp! Đa tạ!
 

File đính kèm

  • QUAN LY THU VIEN chinh sua.xlsm
    1.9 MB · Đọc: 11
Upvote 0
Không biết mình có làm sai chỗ nào ko, hay do dữ liệu tính toán nhiều? (Khoảng 3000 dòng). Anh em chỉ giúp! Đa tạ!
- Kết quả ngay dòng đầu tiên là sai, sheet Sach có 3 quyển, cho mượn 1 quyển trong sheet Sachmuon, cột K chưa có ngày trả tức còn đang mượn, kết quả tồn phải còn 2.
- Dùng tham chiếu cả cột gồm 1048576 dòng (xem trong file), 1 công thức tham chiếu 3 lần nhan lên 3000 cells như vậy thì "tía tui cũng chậm".
- Đã dùng VBA mà "ép" công thức xuống sheet thì "cũng như không".
Gởi bạn 1 Sub chạy thử cho vui.
PHP:
Sub s_Gpe()
Application.ScreenUpdating = False
Dim sArr(), dArr(), I As Long, K As Long, R As Long, R2 As Long, Rws As Long, Txt As String
sArr = Sheets("Sach").Range("C6", Sheets("Sach").Range("C60000").End(xlUp)).Resize(, 10).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 4)
With CreateObject("Scripting.Dictionary")
    '=======================================Gom SL sach theo ten sach'
    For I = 1 To R
        If sArr(I, 1) <> Empty Then
            Txt = UCase(sArr(I, 2))
            If Not .Exists(Txt) Then
                K = K + 1
                .Item(Txt) = K
                dArr(K, 1) = K
                dArr(K, 2) = Txt
            End If
            Rws = .Item(Txt)
            dArr(Rws, 3) = dArr(Rws, 3) + sArr(I, 10)
        End If
    Next I
    '========================================Tim sach muon chua tra'
    R2 = Sheets("Sachmuon").Range("G60000").End(xlUp).Row
    If R2 > 5 Then
        sArr = Sheets("Sachmuon").Range("G6:K" & R2).Value
        R2 = UBound(sArr)
        For I = 1 To R2
            Txt = UCase(sArr(I, 1))
            If .Exists(Txt) Then
                If sArr(I, 5) = Empty Then '-------------Cot K rong, chua tra sach'
                    Rws = .Item(Txt)
                    dArr(Rws, 3) = dArr(Rws, 3) - 1 '----Moi dong chi muon 1 quyen sach ????????'
                End If
            End If
        Next I
    End If
End With
    '========================================Gan ket qua xuong sheet'
    Sheets("Tonkho").Range("A5").Resize(60000, 3).ClearContents
    Sheets("Tonkho").Range("A5").Resize(K, 3) = dArr
End Sub
Không thấy số lượng mượn, có khi nào 1 người mượn 2,3 quyển giống nhau không?
 
Lần chỉnh sửa cuối:
Upvote 0
Xin chào cả nhà, trong file quản lý thư viện mình số lượng tồn kho trong sheet Tonkho (Dựa vào sheet Sach vs sheet Sachmuon) theo code như này (Vừa sao chép dữ liệu không trùng và dùm countif để tính tồn kho)

Mã:
Sub Tonkhosach()
Application.ScreenUpdating = False
' Macro6 Macro
Sheet14.Range("$B$5:CB$65000").Clear
    Sheet3.Range("D6:D65000").Copy
     Sheet14.Range("B5").PasteSpecial Paste:=xlPasteValues
  
Sheet14.Range("B5:B" & 65000).RemoveDuplicates Columns:=1, Header:=xlNo
    
  
    With Sheet14.Range("B4:C10000").Font
         .Name = "Times New Roman"
        .Size = 10
    End With

    'tinhtonkho
  
    Sheet14.Activate
   Dim i As Long
    i = 5
    Do While Sheet14.Cells(i, 2) <> ""
    With Sheet14
    .Cells(i, 3) = Application.WorksheetFunction.CountIfs(Sheet3.Range("D1:D65000"), .Cells(i, 2)) - Application.WorksheetFunction.CountIfs(Sheet6.Range("G1:G65000"), .Cells(i, 2), Sheet6.Range("K1:K65000"), "Muon")
    End With
    i = i + 1
    Loop
Dim dctonkho As Long
dctonkho = Sheet14.Range("B65000").End(xlUp).Row
Range("A4:C65000").Borders.LineStyle = 0
Range("A4:C" & dctonkho).Borders.LineStyle = 1
Sheet14.Range("A4").Select

MsgBox ("Da Cap Nhat Xong")
Application.ScreenUpdating = True
End Sub

Nhưng khi chạy code nó chạy rất lâu.

View attachment 217218

Không biết mình có làm sai chỗ nào ko, hay do dữ liệu tính toán nhiều? (Khoảng 3000 dòng). Anh em chỉ giúp! Đa tạ!
Bạn xem code này đúng không nhé. [ICODE] [CODE]Sub tinhtonkhosach() Dim arr, arr1, dic As Object, i As Long, j As Long, lr As Long, a As Long Set dic = CreateObject("scripting.dictionary") With Sheets("sach") lr = .Range("D" & Rows.Count).End(xlUp).Row If lr < 6 Then Exit Sub arr = .Range("D6:D" & lr).Value ReDim arr1(1 To UBound(arr, 1), 1 To 2) For i = 1 To UBound(arr, 1) If Not dic.exists(arr(i, 1)) Then a = a + 1 dic.Add arr(i, 1), a arr1(a, 1) = arr(i, 1) arr1(a, 2) = 1 Else arr1(dic.Item(arr(i, 1)), 2) = arr1(dic.Item(arr(i, 1)), 2) + 1 End If Next i End With With Sheets("sachmuon") lr = .Range("G" & Rows.Count).End(xlUp).Row arr = .Range("G6:K" & lr).Value For i = 1 To UBound(arr, 1) If UCase(arr(i, 5)) = "MUON" Then If dic.exists(arr(i, 1)) Then arr1(dic.Item(arr(i, 1)), 2) = arr1(dic.Item(arr(i, 1)), 2) - 1 End If End If Next i End With With Sheets("tonkho") lr = .Range("G" & Rows.Count).End(xlUp).Row If lr > 5 Then .Range("B5:C" & lr).ClearContents If a Then .Range("B5:C5").Resize(a).Value = arr1 End With End Sub [/CODE]
[/ICODE]
 
Upvote 0
- Kết quả ngay dòng đầu tiên là sai, sheet Sach có 3 quyển, cho mượn 1 quyển trong sheet Sachmuon, cột K chưa có ngày trả tức còn đang mượn, kết quả tồn phải còn 2.
- Dùng tham chiếu cả cột gồm 1048576 dòng (xem trong file), 1 công thức tham chiếu 3 lần nhan lên 3000 cells như vậy thì "tía tui cũng chậm".
- Đã dùng VBA mà "ép" công thức xuống sheet thì "cũng như không".
Gởi bạn 1 Sub chạy thử cho vui.
PHP:
Sub s_Gpe()
Application.ScreenUpdating = False
Dim sArr(), dArr(), I As Long, K As Long, R As Long, R2 As Long, Rws As Long, Txt As String
sArr = Sheets("Sach").Range("C6", Sheets("Sach").Range("C60000").End(xlUp)).Resize(, 10).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 4)
With CreateObject("Scripting.Dictionary")
    '=======================================Gom SL sach theo ten sach'
    For I = 1 To R
        If sArr(I, 1) <> Empty Then
            Txt = UCase(sArr(I, 2))
            If Not .Exists(Txt) Then
                K = K + 1
                .Item(Txt) = K
                dArr(K, 1) = K
                dArr(K, 2) = Txt
            End If
            Rws = .Item(Txt)
            dArr(Rws, 3) = dArr(Rws, 3) + sArr(I, 10)
        End If
    Next I
    '========================================Tim sach muon chua tra'
    R2 = Sheets("Sachmuon").Range("G60000").End(xlUp).Row
    If R2 > 5 Then
        sArr = Sheets("Sachmuon").Range("G6:K" & R2).Value
        R2 = UBound(sArr)
        For I = 1 To R2
            Txt = UCase(sArr(I, 1))
            If .Exists(Txt) Then
                If sArr(I, 5) = Empty Then '-------------Cot K rong, chua tra sach'
                    Rws = .Item(Txt)
                    dArr(Rws, 3) = dArr(Rws, 3) - 1 '----Moi dong chi muon 1 quyen sach ????????'
                End If
            End If
        Next I
    End If
End With
    '========================================Gan ket qua xuong sheet'
    Sheets("Tonkho").Range("A5").Resize(60000, 3).ClearContents
    Sheets("Tonkho").Range("A5").Resize(K, 3) = dArr
End Sub
Không thấy số lượng mượn, có khi nào 1 người mượn 2,3 quyển giống nhau không?
Chạy đúng rồi anh Ba Tê, mỗi người mượn 1 dòng. Cơ mà mình cho chế độ không phân biệt viết hoa thường đc ko, ví dụ như dưới đây là 1:
217246

Ah thêm nữa là trong code nó chưa trừ số lượng đã mượn! Nghĩa là cột đã trả trống thì nghĩa là còn mượn, còn chỗ nào đã trả thì ko trừ, vì đã nhập lại kho. Mỗi dòng mượn là 1 cuốn.
Bài đã được tự động gộp:

Bạn xem code này đúng không nhé. [ICODE] [CODE]Sub tinhtonkhosach() Dim arr, arr1, dic As Object, i As Long, j As Long, lr As Long, a As Long Set dic = CreateObject("scripting.dictionary") With Sheets("sach") lr = .Range("D" & Rows.Count).End(xlUp).Row If lr < 6 Then Exit Sub arr = .Range("D6:D" & lr).Value ReDim arr1(1 To UBound(arr, 1), 1 To 2) For i = 1 To UBound(arr, 1) If Not dic.exists(arr(i, 1)) Then a = a + 1 dic.Add arr(i, 1), a arr1(a, 1) = arr(i, 1) arr1(a, 2) = 1 Else arr1(dic.Item(arr(i, 1)), 2) = arr1(dic.Item(arr(i, 1)), 2) + 1 End If Next i End With With Sheets("sachmuon") lr = .Range("G" & Rows.Count).End(xlUp).Row arr = .Range("G6:K" & lr).Value For i = 1 To UBound(arr, 1) If UCase(arr(i, 5)) = "MUON" Then If dic.exists(arr(i, 1)) Then arr1(dic.Item(arr(i, 1)), 2) = arr1(dic.Item(arr(i, 1)), 2) - 1 End If End If Next i End With With Sheets("tonkho") lr = .Range("G" & Rows.Count).End(xlUp).Row If lr > 5 Then .Range("B5:C" & lr).ClearContents If a Then .Range("B5:C5").Resize(a).Value = arr1 End With End Sub [/CODE]
[/ICODE]
Cảm ơn Snow!
Mình kiểm tra lại là ko đủ số dòng, nghĩa là một số sách lọc ra bị thiếu. Snow xem lại thử!
 
Lần chỉnh sửa cuối:
Upvote 0
Cơ mà mình cho chế độ không phân biệt viết hoa thường đc ko, ví dụ như dưới đây là 1:
217246
Không hiểu từ đâu có dữ liệu như hình. Code của tôi coi như đã không phân biệt chữ Hoa - Thường.
 
Upvote 0
Em chào anh chị ạ,
Nhờ anh chị giúp em 1 code gửi mail tự động vừa đính kèm file vừa gửi một biểu đồ cụ thể trong file đó ở sheet 1 trong cùng một Email để trình bày biểu đồ ở phần body của mail được không ạ. Em cám ơn mọi người nhiều.
 

File đính kèm

  • Test.xls
    56 KB · Đọc: 7
Upvote 0
Upvote 0
Bạn xem code này đúng không nhé. [ICODE] [CODE]Sub tinhtonkhosach() Dim arr, arr1, dic As Object, i As Long, j As Long, lr As Long, a As Long Set dic = CreateObject("scripting.dictionary") With Sheets("sach") lr = .Range("D" & Rows.Count).End(xlUp).Row If lr < 6 Then Exit Sub arr = .Range("D6:D" & lr).Value ReDim arr1(1 To UBound(arr, 1), 1 To 2) For i = 1 To UBound(arr, 1) If Not dic.exists(arr(i, 1)) Then a = a + 1 dic.Add arr(i, 1), a arr1(a, 1) = arr(i, 1) arr1(a, 2) = 1 Else arr1(dic.Item(arr(i, 1)), 2) = arr1(dic.Item(arr(i, 1)), 2) + 1 End If Next i End With With Sheets("sachmuon") lr = .Range("G" & Rows.Count).End(xlUp).Row arr = .Range("G6:K" & lr).Value For i = 1 To UBound(arr, 1) If UCase(arr(i, 5)) = "MUON" Then If dic.exists(arr(i, 1)) Then arr1(dic.Item(arr(i, 1)), 2) = arr1(dic.Item(arr(i, 1)), 2) - 1 End If End If Next i End With With Sheets("tonkho") lr = .Range("G" & Rows.Count).End(xlUp).Row If lr > 5 Then .Range("B5:C" & lr).ClearContents If a Then .Range("B5:C5").Resize(a).Value = arr1 End With End Sub [/CODE]
[/ICODE]
Trong code này snow đã trừ phần mượn ở sheet Sachmuon chưa ạ? tại mình thấy nó ko trừ cho 1 quyển đã mượn ở sheet Sachmuon.
Cụ thể, sheet mượn sách, cột đã trả còn trống chưa ghi ngày trả thì có nghĩa là sách chưa trả, phải trừ, còn nếu không trống (đã ghi ngày trả) thì mình ko trừ vì đã thu hồi vào kho rồi.
 
Upvote 0
Trong code này snow đã trừ phần mượn ở sheet Sachmuon chưa ạ? tại mình thấy nó ko trừ cho 1 quyển đã mượn ở sheet Sachmuon.
Cụ thể, sheet mượn sách, cột đã trả còn trống chưa ghi ngày trả thì có nghĩa là sách chưa trả, phải trừ, còn nếu không trống (đã ghi ngày trả) thì mình ko trừ vì đã thu hồi vào kho rồi.
Bạn ấy đọc theo code của bạn trong bài #2090 có dòng này
PHP:
.Cells(i, 3) = Application.WorksheetFunction.CountIfs(Sheet3.Range("D1:D65000"), .Cells(i, 2)) - Application.WorksheetFunction.CountIfs(Sheet6.Range("G1:G65000"), .Cells(i, 2), Sheet6.Range("K1:K65000"), "Muon")
Vì thế muốn kết quả đúng phải nhập "Muon" vào cột "Ngày trả" sheet "Sachmuon"
 
Upvote 0
Bạn ấy đọc theo code của bạn trong bài #2090 có dòng này
PHP:
.Cells(i, 3) = Application.WorksheetFunction.CountIfs(Sheet3.Range("D1:D65000"), .Cells(i, 2)) - Application.WorksheetFunction.CountIfs(Sheet6.Range("G1:G65000"), .Cells(i, 2), Sheet6.Range("K1:K65000"), "Muon")
Vì thế muốn kết quả đúng phải nhập "Muon" vào cột "Ngày trả" sheet "Sachmuon"
AH AH, đã hiểu và đã sửa lại code chạy đúng rồi, đa tạ Ba Tê vs snow rất nhiều!
 
Upvote 0
TỰ ĐỘNG BACKUP FILE EXCEL!

Xin chào cả nhà, mình viết một phần mềm, nhưng mình thận trọng và muốn TỰ ĐỘNG sao lưu file Excel đó ra một file mới (Save As) theo thời gian định sẵn (ví dụ vào lúc 10h sáng chẳn hạn), với tên là ngày_tháng_năm, lưu vào một thư mục do mình quy định. Để khi bị lỗi hoặc có vấn đề gì mình còn lấy lại được.

Mình đã tìm nát google và trên diễn đàn rồi mà chưa thấy bài nào nói về vấn đề này, mong anh em hướng dẫn! Đa tạ!
 
Upvote 0
TỰ ĐỘNG BACKUP FILE EXCEL!

Xin chào cả nhà, mình viết một phần mềm, nhưng mình thận trọng và muốn TỰ ĐỘNG sao lưu file Excel đó ra một file mới (Save As) theo thời gian định sẵn (ví dụ vào lúc 10h sáng chẳn hạn), với tên là ngày_tháng_năm, lưu vào một thư mục do mình quy định. Để khi bị lỗi hoặc có vấn đề gì mình còn lấy lại được.

Mình đã tìm nát google và trên diễn đàn rồi mà chưa thấy bài nào nói về vấn đề này, mong anh em hướng dẫn! Đa tạ!
Xin góp ý cho bài viết:

Xin góp ý cho bài viết:
1> Đã ở mức tìm tòi nát google rùi thì trình vba chác cũng vượt qua đẳng cấp: coppy và paste, và biết thế nào la module...Ghi và chạy một macro.
2> Tham khảo link này : https://www.extendoffice.com/vi/documents/excel/4409-excel-repeat-macro-every-minute.html >>> tạo thời gian chạy.
3> muốn có code lưu thì ghi lại một đoạn mã macro cho việc save as và đổi tên, nơi lưu>>>>sửa code và kết hợp code là OK
Mong bạn làm được
[/QUOTE]
 
Upvote 0
TỰ ĐỘNG BACKUP FILE EXCEL!

Xin chào cả nhà, mình viết một phần mềm, nhưng mình thận trọng và muốn TỰ ĐỘNG sao lưu file Excel đó ra một file mới (Save As) theo thời gian định sẵn (ví dụ vào lúc 10h sáng chẳn hạn), với tên là ngày_tháng_năm, lưu vào một thư mục do mình quy định. Để khi bị lỗi hoặc có vấn đề gì mình còn lấy lại được.

Mình đã tìm nát google và trên diễn đàn rồi mà chưa thấy bài nào nói về vấn đề này, mong anh em hướng dẫn! Đa tạ!

Bạn xem bài này, cũng tương tự như yêu cầu của bạn, chỉ khác là của bạn sẽ dễ hơn vì chỉ cần Save As. Dùng Task Schedule có sẳn trong Windows kết hơp VBScript.

Link: https://www.giaiphapexcel.com/diend...g-mở-file-khi-có-nhắc-nhở.141245/#post-909100

- Cách làm này thì bạn không cần phải mở file Excel cần lưu để chạy macro Save as bên trong nó.
- Copy đoạn code dứoi vào NotePad và lưu thành file .bat (đặt tên bất kỳ, Vd: saoluu.bat)
- Dùng Task Schedule để chạy file .bat này.

Mã:
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\Test\Book1.xlsm")
objExcel.Application.Visible = False
NgayThang = Year(now) & Right("0" & Month(Now), 2) & Right("0" & Day(now), 2)

objExcel.Activeworkbook.SaveAs "D:\Test\Backup\Book1_" & NgayThang & ".xlsm"
objExcel.DisplayAlerts = False
objExcel.Activeworkbook.Close
objExcel.Quit
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT
Back
Top Bottom