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

Liên hệ QC
maytinhvp01

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:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
khuongvietphong đã viết:
Em có giải bài tập này bằng cách sử dụng 2 làn Dic, tuy nhiên không hiểu sao cứ bị báo lỗi ở dòng bôi đỏ, mọi người chỉnh lại giúp em nha:
Mã: 
Option Explicit
---------------------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "C1" Then
  Range("C2:C9").ClearContents
  Dim dic1 As Object, dic2 As Object, i As Long, j As Long
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
'========================================================
For i = 2 To 8
  If Cells(i, 2).Value = Target.Value Then
     dic1.Add Cells(i, 1).Value, ""
  End If
Next i
'========================================================
For j = 2 To 8
  If Not dic1.exists(Cells(j, 1).Value) Then
[B][COLOR=#ff0000]    dic2.Add Cells(j, 1).Value, ""[/COLOR][/B]
  End If
Next j
'==========================================================
  Range("C2").Resize(dic2.Count) = WorksheetFunction.Transpose(dic2.keys)
End If
  
End Sub

Yêu cầu của bào tập là lập liệt kê các tỉnh mà tên người được cho ở cell C1 chưa từng đến.
Nhấp chuột vào đây để mở rộng...
Bài này dung Advanced Filter là đẹp nhất: Không vòng lập + code ngắn gọn, dễ hiểu
 
Upvote 0
Bài này có nhiều cách giải. Có lẽ cách filter như bài #627 là chính chắn nhất. Vì trong Excel thì dùng công cụ Excel là tốt nhất.

Tuy nhiên, vì chủ đề bài có ý muốn dùng Dic, và vì hàm remove của dic ít thấy dùng tới, cho nên nhân dịp này tôi đề nghị thử 2 loại code sau đây

Mã: 
[COLOR=#ff0000]' lưu ý: code sau đây chỉ có tính cách demo cho nên tôi viết rất vắn tắt. Không nên dùng trên thực tế
[/COLOR]
Sub t()

' dùng 1 dic, 2 vòng lặp
' giải thuật:
' đọc mảng, nhét cột 1 làm key của dic, nếu cột 2 xét đúng thì cộng value (item) cho 1, nếu cột 2 không thì cộng cho 0
' duyệt dic, nếu dòng nào có value (item) > 0 thì là đúng trị, xoá nó đi
' chỗ còn lại trên dic là kết quả

With CreateObject("scripting.dictionary")
    For Each r In [a2:b8].Rows
        .Item(r.Cells(1).Value) = .Item(r.Cells(1).Value) + IIf(r.Cells(2).Value = [c1].Value, 1, 0)
    Next r
    For Each k In .keys
        If .Item(k) > 0 Then .Remove k
    Next k
    [c2].Resize(.Count) = Application.Transpose(.keys)
End With
End Sub

Sub t2()

' dùng 2 dics, 1 vòng lặp
' giải thuật:
' đọc mảng, nếu cột 2 xét đúng thì nhét cột 1 làm key của dic d2, và đồng thời xoá khỏi d1. Nếu cột 2 không đúng thì xét nếu không có trong d2 thì nhét vào d1
' chỗ còn lại trên dic d1 là kết quả

Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For Each r In [a2:b8].Rows
    If r.Cells(2).Value = [c1].Value Then
        d2.Item(r.Cells(1).Value) = ""
        If d1.exists(r.Cells(1).Value) Then d1.Remove (r.Cells(1).Value)
    Else
        If Not d2.exists(r.Cells(1).Value) Then d1.Item(r.Cells(1).Value) = ""
    End If
Next r
[c2].Resize(d1.Count) = Application.Transpose(d1.keys)
End Sub
 
Upvote 0
concogia đã viết:
Cuối năm rồi, tui không muốn em "Đít-to" và chỉ chơi một vòng lặp thôi cho ......đỡ chóng mặt có được hông?????? _)()(-_)()(-_)()(-
CHÚC MỪNG NĂM MỚI (sớm tý tẹo)
Nhấp chuột vào đây để mở rộng...

Bé còi xin phép được tiếp chiêu bác Cò, hy vọng bác cò đỡ chóng mặt hơn vì vòng lặp ạ, chúc bác cò 1 năm mới vui vẻ, :)

Phần còn lại nhờ các sư huynh khác tiếp chiêu chứ hiện giờ bé còi cũng đang chóng mặt đi không nổi rồi =)))))) hihihi.

P/s : Bé còi vẫn chờ giải pháp ADO của anh Hai Lúa Miền Tây nữa, năm nay chắc em được mùa cá cược quá. hehee

Mã: 
Sub HelloWorld()
Dim i As Long, Tmp
Dim sArr()
sArr = Range("A2:B" & [B65536].End(xlUp).Row).Value
For i = 1 To UBound(sArr)
    If InStr(Tmp, sArr(i, 1)) = 0 Then
        Tmp = Tmp & "#" & sArr(i, 1)
    End If
    If sArr(i, 2) = [C1] Then
            Tmp = Replace(Tmp, sArr(i, 1), "")
    End If
Next
MsgBox "Cac tinh chua di la : " & Application.WorksheetFunction.Trim(Replace(Tmp, "#", " "))
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
hoamattroicoi đã viết:
Bé còi xin phép được tiếp chiêu bác Cò, hy vọng bác cò đỡ chóng mặt hơn vì vòng lặp ạ, chúc bác cò 1 năm mới vui vẻ, :)

Phần còn lại nhờ các sư huynh khác tiếp chiêu chứ hiện giờ bé còi cũng đang chóng mặt đi không nổi rồi =)))))) hihihi.

P/s : Bé còi vẫn chờ giải pháp ADO của anh Hai Lúa Miền Tây nữa, năm nay chắc em được mùa cá cược quá. hehee

Mã: 
Sub [COLOR=#ff0000][B]Hello[/B][/COLOR]World()
Dim i As Long, Tmp
Dim sArr()
sArr = Range("A2:B" & [B65536].End(xlUp).Row).Value
For i = 1 To UBound(sArr)
    If InStr(Tmp, sArr(i, 1)) = 0 Then
        Tmp = Tmp & "#" & sArr(i, 1)
    End If
    If sArr(i, 2) = [C1] Then
            Tmp = Replace(Tmp, sArr(i, 1), "")
    End If
Next
MsgBox "Cac tinh chua di la : " & Application.WorksheetFunction.Trim(Replace(Tmp, "#", " "))
End Sub
Nhấp chuột vào đây để mở rộng...

bình thường thì mình không để ý lắm đâu , nhưng có chữ hello thì phải "quan tâm" thôi
sửa A8 = "Huế" A1 = "Tuấn" đi bạn gì ơi
 
Upvote 0
doveandrose đã viết:
bình thường thì mình không để ý lắm đâu , nhưng có chữ hello thì phải "quan tâm" thôi
sửa A8 = "Huế" A1 = "Tuấn" đi bạn gì ơi
Nhấp chuột vào đây để mở rộng...
Hehee, vậy chuyển thành A nhô cho đỡ liên quan nha, đôi khi xóa sạch dấu vết không phải là cách hay lắm. Cảm ơn bạn doveandrose...:)

Mã: 
Sub Anh0World()
Dim i As Long, Tmp, Tmp1
Dim sArr()
sArr = Range("A2:B" & [B65536].End(xlUp).Row).Value
For i = 1 To UBound(sArr)
    If InStr(Tmp, sArr(i, 1)) = 0 Then
        Tmp = Tmp & "#" & sArr(i, 1)
    End If
    If sArr(i, 2) = [C1] Then
            Tmp1 = Tmp1 & sArr(i, 1)
    End If
    If InStr(Tmp1, sArr(i, 1)) Then
        Tmp = Replace(Tmp, sArr(i, 1), "")
    End If
Next
MsgBox "Cac tinh chua di la : " & Application.WorksheetFunction.Trim(Replace(Tmp, "#", " "))
End Sub
 
Upvote 0
hoamattroicoi đã viết:
Hehee, vậy chuyển thành A nhô cho đỡ liên quan nha, đôi khi xóa sạch dấu vết không phải là cách hay lắm. Cảm ơn bạn doveandrose...:)

Mã: 
Sub Anh0World()
Dim i As Long, Tmp, Tmp1
Dim sArr()
sArr = Range("A2:B" & [B65536].End(xlUp).Row).Value
For i = 1 To UBound(sArr)
    If InStr(Tmp, sArr(i, 1)) = 0 Then
        Tmp = Tmp & "#" & sArr(i, 1)
    End If
    If sArr(i, 2) = [C1] Then
            Tmp1 = Tmp1 & sArr(i, 1)
    End If
    If InStr(Tmp1, sArr(i, 1)) Then
        Tmp = Replace(Tmp, sArr(i, 1), "")
    End If
Next
MsgBox "Cac tinh chua di la : " & Application.WorksheetFunction.Trim(Replace(Tmp, "#", " "))
End Sub
Nhấp chuột vào đây để mở rộng...
Trường hợp điều kiện không phải là C1 mà là cột C thì có thể thêm 1 vòng lặp?
 
Upvote 0
dhn46 đã viết:
Theo như tôi biết thì Excel không thực hiện được mệnh đề DELETE

Bạn có thể dùng phương pháp xóa thông thường cho trường hợp này (Mở WB, xóa, lưu WB) hoặc đợi câu trả lời các phương án ADO khác.
Nhấp chuột vào đây để mở rộng...
Dùng câu lệnh Update Set tencot=null, tuy nhiên dùng cách này sẽ có nhiều dòng trống.
 
Upvote 0
Upvote 0
hoamattroicoi đã viết:
Bé còi xin phép được tiếp chiêu bác Cò, hy vọng bác cò đỡ chóng mặt hơn vì vòng lặp ạ, chúc bác cò 1 năm mới vui vẻ, :)

Phần còn lại nhờ các sư huynh khác tiếp chiêu chứ hiện giờ bé còi cũng đang chóng mặt đi không nổi rồi =)))))) hihihi.

P/s : Bé còi vẫn chờ giải pháp ADO của anh Hai Lúa Miền Tây nữa, năm nay chắc em được mùa cá cược quá. hehee

Mã: 
Sub HelloWorld()
Dim i As Long, Tmp
Dim sArr()
sArr = Range("A2:B" & [B65536].End(xlUp).Row).Value
For i = 1 To UBound(sArr)
    If InStr(Tmp, sArr(i, 1)) = 0 Then
        Tmp = Tmp & "#" & sArr(i, 1)
    End If
    If sArr(i, 2) = [C1] Then
            Tmp = Replace(Tmp, sArr(i, 1), "")
    End If
Next
MsgBox "Cac tinh chua di la : " & Application.WorksheetFunction.Trim(Replace(Tmp, "#", " "))
End Sub
Nhấp chuột vào đây để mở rộng...
Làm đại, hong biết trúng hay trật.

Mã: 
Sub test()

    Dim cn As Object, strSQL As String, strSQL1 As String, strSQL2 As String
    Set cn = CreateObject("adodb.connection")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
            ";Extended Properties=""Excel 12.0;HDR=NO;ReadOnly=True"";"
            
    strSQL1 = strSQL1 & "SELECT [Sheet1$A1:C100].F3 " & vbCrLf
    strSQL1 = strSQL1 & "FROM [Sheet1$A1:C100] " & vbCrLf
    strSQL1 = strSQL1 & "WHERE ((([Sheet1$A1:C100].F3) Is Not Null))"
    
    strSQL2 = strSQL2 & "SELECT DISTINCT [Sheet1$A2:C100].F1 " & vbCrLf
    strSQL2 = strSQL2 & "FROM [Sheet1$A2:C100] INNER JOIN (" & strSQL1 & ") as Q2 ON [Sheet1$A2:C100].F2 = Q2.F3"
    
    strSQL = strSQL & "SELECT DISTINCT [Sheet1$A2:C100].F1 " & vbCrLf
    strSQL = strSQL & "FROM ([Sheet1$A2:C100] LEFT JOIN (" & strSQL2 & ") as Q1 " & vbCrLf
    strSQL = strSQL & "    ON [Sheet1$A2:C100].F1 = Q1.F1) LEFT JOIN (" & strSQL1 & ") as Q2 ON [Sheet1$A2:C100].F2 = Q2.F3 " & vbCrLf
    strSQL = strSQL & "WHERE (((Q1.F1) Is Null) AND ((Q2.F3) Is Null));"
    Sheet1.Range("D2:D10").ClearContents
    Sheet1.Range("D2").CopyFromRecordset cn.Execute(strSQL)
    
End Sub
 
Upvote 0
Mã: 
Sub t()
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
            ";Extended Properties=""Excel 12.0;HDR=NO;ReadOnly=True"";"
    strSQL = "Select Distinct f1 From Tab1 as T1a" _
            & " Where Not Exists (Select Null From Tab1 as T1 Inner Join Tab2 as T2 On T1.f2 = T2.f1" _
            & " Where T1a.f1 = T1.f1)"
    strSQL = Replace(Replace(strSQL, "Tab1", "[Sheet1$A2:B100]"), "Tab2", "[Sheet1$C1:C100]")
    Sheet1.Range("D1:D100").ClearContents
    With CreateObject("adodb.connection")
        .Open strCon
        Sheet1.Range("D1").CopyFromRecordset .Execute(strSQL)
    End With
End Sub
 
Upvote 0
em chào các anh ạ
các anh giúp em với
em có viết code

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Sheet7.Activate
Application.Caption = " "
ActiveWindow.Caption = " "
Toolbars("control toolbox").Visible = False
Toolbars(5).Visible = False
Toolbars(7).Visible = False
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayOutline = False
.DisplayZeros = False
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
End With
ActiveSheet.Protect (" ")
Application.ScreenUpdating = True
End Sub

nhưng khi chạy báo lỗi
Method 'Activate' of object '_Worksheet' failed
các anh giúp em sửa lỗi với ạ
em cảm ơn các anh nhiều
 
Upvote 0
authority đã viết:
em chào các anh ạ
các anh giúp em với
em có viết code

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Sheet7.Activate
Application.Caption = " "
ActiveWindow.Caption = " "
Toolbars("control toolbox").Visible = False
Toolbars(5).Visible = False
Toolbars(7).Visible = False
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayOutline = False
.DisplayZeros = False
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
End With
ActiveSheet.Protect (" ")
Application.ScreenUpdating = True
End Sub

nhưng khi chạy báo lỗi
Method 'Activate' of object '_Worksheet' failed
các anh giúp em sửa lỗi với ạ
em cảm ơn các anh nhiều
Nhấp chuột vào đây để mở rộng...
Không có file thì ai biết bệnh gì mà chữa hả bạn.
 
Upvote 0
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

H
  • Question
nhờ các bác viết mẫu cho em lệnh dùng checkbox để rút ngắn thời gian thao tác
Trả lời
13
Đọc
269
giaiphap
giaiphap
C
  • Question
VBA copy 2 vùng dữ liệu từ 1 workbook này sang 2 vùng của workbook khác!
    • Phẫn nộ
Trả lời
3
Đọc
60
VetMini
V
T
  • Question
Ghép 2 cột dữ liệu
Trả lời
4
Đọc
84
VetMini
V
A
[Góc giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word cấu trúc giống nhau vào 1 file excel mẫu
Trả lời
3
Đọc
83
Manhhung90
Manhhung90
8
Hàm thống kê số lượng thành viên câu lạc bộ theo từng đợt tuyển thành viên
Trả lời
4
Đọc
126
8589934592
8
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

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

Back
Top Bottom