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

Liên hệ QC

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

Đang trực tuyến: 5 (Thành viên: 0, Khách: 5)
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
ndhmoney686 đã viết:
Bạn ơi mình tải file của bạn giúp mình về. Mình xóa cái conditional formating với công thức =IF($F10<>"";TRUE;FALSE)
Thì nó ko tự kẻ dòng được. Bạn xem lại giúp mình với nhé. Cám ơn Bạn!
Nhấp chuột vào đây để mở rộng...
Sheet B2 không có code thì đương nhiên không có tác dụng gì là đúng rồi. Bạn sử dụng code sau cho sheet B2 nhé:
[GPECODE=vb]Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Intersect(Target, [F11:F43]) Is Nothing Then Exit Sub
For Each Cll In Intersect(Target, [F11:F43])
Cll.Resize(, 12).Borders.LineStyle = (Cll <> "")
Next
End Sub[/GPECODE]
 
Upvote 0
nghiaphuc đã viết:
Sheet B2 không có code thì đương nhiên không có tác dụng gì là đúng rồi. Bạn sử dụng code sau cho sheet B2 nhé:
[GPECODE=vb]Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Intersect(Target, [F11:F43]) Is Nothing Then Exit Sub
For Each Cll In Intersect(Target, [F11:F43])
Cll.Resize(, 12).Borders.LineStyle = (Cll <> "")
Next
End Sub[/GPECODE]
Nhấp chuột vào đây để mở rộng...

CODE của anh NghĩaPhúc ngắn gọn quá !
 
Lần chỉnh sửa cuối:
Upvote 0
Upvote 0
ndhmoney686 đã viết:
Cám ơn Bạn Khuongvietphong và Anh Nghĩa Phúc.
Nếu như đường kẻ em chon theo mầu. VD mầu xanh bất kỳ. A/C chỉnh thêm giúp Em.
Nhấp chuột vào đây để mở rộng...

Trong Code của mình chỗ ColorIndex bạn cho nó giá trị bằng 4 là được, còn của anh Phúc thì mình chưa biết chỉnh thế nào
 
Lần chỉnh sửa cuối:
Upvote 0
ndhmoney686 đã viết:
Cám ơn Bạn Khuongvietphong và Anh Nghĩa Phúc.
Nếu như đường kẻ em chon theo mầu. VD mầu xanh bất kỳ. A/C chỉnh thêm giúp Em.
Nhấp chuột vào đây để mở rộng...
Bạn có thể thêm câu lệnh này vào trong vòng For:
Mã: 
If Cll <> "" Then Cll.Resize(, 12).Borders.ColorIndex = 5
Để tham khảo thêm về giá trị tương ứng với các màu (thay cho số 5 ở câu lệnh trên), bạn có thể chạy code này, nên chọn 1 sheet trống trước khi chạy code:
[GPECODE=vb]Sub Test()
Dim i As Long
For i = 1 To 56
Cells(i, 1).Interior.ColorIndex = i
Next
End Sub[/GPECODE]
 
Upvote 0
Mình mù tịt về vba, mình có ví dụ dưới đây, ai biết giúp mình với, xin chân thành cảm ơn!
 
Upvote 0
Upvote 0
Hiện tại cột C em đang sử dụng name "MatHang" và cột F em đang sử dụng name "ThanhTien"

Nếu sử dụng name như hiện tại như của Em. Nếu dữ liệu nhiều thì mỗi lần cập nhập dữ liệu file thường tính toán rất chậm.

Em nhờ A/C giúp Em viết code lấy mặt hàng cho cột C và tính Thành tiền cho cột F. Khi viết A/C giúp Em lấy công thức tính toán theo name có sẵn của Em (bởi vì nếu lắp name có sẵn của em vào trong code thì sẽ tiện cho em hơn với các trường hợp khác để ứng dụng. Công thức theo code nhiều cái em chưa hiểu)

A/C giúp em để code ở sự kiện worksheetchange. Em cám ơn A/C!
 

File đính kèm

  • Untitled.jpg
    Untitled.jpg
    16.9 KB · Đọc: 6
  • Codename.xls
    Codename.xls
    35 KB · Đọc: 6
Upvote 0
ndhmoney686 đã viết:
Hiện tại cột C em đang sử dụng name "MatHang" và cột F em đang sử dụng name "ThanhTien"

Nếu sử dụng name như hiện tại như của Em. Nếu dữ liệu nhiều thì mỗi lần cập nhập dữ liệu file thường tính toán rất chậm.

Em nhờ A/C giúp Em viết code lấy mặt hàng cho cột C và tính Thành tiền cho cột F. Khi viết A/C giúp Em lấy công thức tính toán theo name có sẵn của Em (bởi vì nếu lắp name có sẵn của em vào trong code thì sẽ tiện cho em hơn với các trường hợp khác để ứng dụng. Công thức theo code nhiều cái em chưa hiểu)

A/C giúp em để code ở sự kiện worksheetchange. Em cám ơn A/C!
Nhấp chuột vào đây để mở rộng...

thật tiếc là tôi không biết sử dụng name vào code !$@!!!$@!!, nếu gặp tôi thì tôi viết thẳng code vào sự kiện Change mà không thông qua name nào hết , nên chắc bạn chờ thành viên khác .
 
Upvote 0
doveandrose đã viết:
thật tiếc là tôi không biết sử dụng name vào code !$@!!!$@!!, nếu gặp tôi thì tôi viết thẳng code vào sự kiện Change mà không thông qua name nào hết , nên chắc bạn chờ thành viên khác .
Nhấp chuột vào đây để mở rộng...
Thay vì ghi range("c1:C...") thì mình có thể ghi name tương tự, range("tên name")
 
Upvote 0
Xin anh(chị) cho biết tại sao khi nhập đúng mã rồi mà nó vẫn hiện lên hộp thông báo MsgBox vậy. Thậm chí em đã cho cả câu lệnh Exit Sub vàorồi mà sao nó vẫn không được vậy.
 

File đính kèm

Upvote 0
Bạn không tạm ngưng sự kiện chnage cho nên code chạy 2 lần
 
Upvote 0
Em có dùng macro để copy các name ở dòng đầu tiên của 1 vùng công thức, để dán xuống các dòng phía dưới (dạng công thức). Rồi lại copy và pase lại (dạng giá trị). Để nhằm giảm công thức quá nhiều cho file. Hiện tại Em chưa viết được code cho các công thức đang dùng. Nên tạm thời thực hiện copy pase theo cách này. A/C xem giúp Em đoạn code ở dưới xem có thể tối ưu được hơn ko. Và có thể rút ngắn lại và giúp cho code nhanh hơn thì tuyệt. Mong A/C giúp Em. Cám ơn A/C nhiều!

Sub NXT ()
'Mở Protect
ActiveSheet.Unprotect

'Clear fillter - Nếu đang fillter copy pase sẽ lỗi
ActiveSheet.ShowAllData

'Chọn dòng I10 tới T10 là dòng có name và thực hiện lệnh copy
Range("I10:T10").Select
Selection.Copy

'Chọn vùng cần dán kết quả tử I11 tới T11. thực hiện pase name (dạng công thức)
Range("I11:T11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas

'Thực hiện lệnh copy rồi pase value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues

'Ở cột H thực hiện fillter để lọc những dòng có dữ liệu
ActiveSheet.Range("$H$9:$T$509").AutoFilter Field:=1, Criteria1:="<>"

'Sau khi thực hiện các lệnh ở trên xong thì Protec sheet lại
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFiltering:=True

End Sub
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
Em ngồi chỉnh lại code như sau. Mong A/C chỉ bảo Em. Cám ơn A/C nhiều!
Sub PasteNameNXTKho()
ActiveSheet.ShowAllData
Range("E10:P10").Copy
Range("E11:P498").PasteSpecial Paste:=xlPasteFormulas
Range("E11:P498").Copy
Range("E11:P498").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveSheet.Range("$D$9:$P$509").AutoFilter Field:=1, Criteria1:="<>"
Calculate
Range("E11").Select
End Sub
Nhấp chuột vào đây để mở rộng...
Sub NXT ()
'Clear fillter - Sử dụng để bỏ chế độ đang fillter ở một cột nào đó (Nếu đang fillter mà thực hiện copy paste sẽ lỗi)
ActiveSheet.ShowAllData
'Chọn dòng I10 tới T10 là dòng có name và thực hiện lệnh copy
Range("E10:P10").Copy
'Chọn vùng cần dán kết quả tử E11 tới P498. thực hiện paste name (dạng công thức)
Range("E11:P498").PasteSpecial Paste:=xlPasteFormulas
'Thực hiện lệnh copy vùng vừa dán name (dạng công thức). và paste lại dạng giá trị
Range("E11:P498").Copy
Range("E11:P498").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Ở cột H dùng để lọc những dòng có dữ liệu
ActiveSheet.Range("$H$9:$T$509").AutoFilter Field:=1, Criteria1:="<>"
End Sub​
 
Lần chỉnh sửa cuối:
Upvote 0
ndhmoney686 đã viết:
Em ngồi chỉnh lại code như sau. Mong A/C chỉ bảo Em. Cám ơn A/C nhiều!

Sub NXT ()
'Clear fillter - Sử dụng để bỏ chế độ đang fillter ở một cột nào đó (Nếu đang fillter mà thực hiện copy paste sẽ lỗi)
ActiveSheet.ShowAllData
'Chọn dòng I10 tới T10 là dòng có name và thực hiện lệnh copy
Range("E10:P10").Copy
'Chọn vùng cần dán kết quả tử E11 tới P498. thực hiện paste name (dạng công thức)
Range("E11:P498").PasteSpecial Paste:=xlPasteFormulas
'Thực hiện lệnh copy vùng vừa dán name (dạng công thức). và paste lại dạng giá trị
Range("E11:P498").Copy
Range("E11:P498").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Ở cột H dùng để lọc những dòng có dữ liệu
ActiveSheet.Range("$H$9:$T$509").AutoFilter Field:=1, Criteria1:="<>"
End Sub​
Nhấp chuột vào đây để mở rộng...
ActiveSheet.ShowAllData : Bị lỗi khi không Filter cột nào.
Thêm bẫy lỗi: If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
-------------------------------------------------

Range("E11:P498").Copy
Range("E11:P498").PasteSpecial Paste:=xlPasteValues
Có thể thay bằng:
Range("E11:P498").Value=Range("E11:P498").Value
 
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
ActiveSheet.ShowAllData : Bị lỗi khi không Filter cột nào.
Thêm bẫy lỗi: If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
-------------------------------------------------

Range("E11:P498").Copy
Range("E11:P498").PasteSpecial Paste:=xlPasteValues
Có thể thay bằng:
Range("E11:P498").Value=Range("E11:P498").Value
Nhấp chuột vào đây để mở rộng...

Em cám ơn Anh Bate. Hôm qua Em cũng đang định hỏi cách dùng IF vào nếu ko có cột nào fillter thì bỏ qua. Nhưng lại ngại nên thôi. hi' .... Cám ơn Anh!
 
Upvote 0
Em cho thêm cái If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
Khi chạy thì nó báo lỗi như sau:
Compile error:
End If without block If

A/C xem giúp Em lỗi này với ạ.

Sub NXTKho()
On Error Resume Next
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
Range("E3:P3").Copy
Range("E10:P348").PasteSpecial Paste:=xlPasteFormulas
Range("E10:P348").Value = Range("E10:P348").Value
ActiveSheet.Range("$D$9:$D$350").AutoFilter Field:=1, Criteria1:="<>"
End If
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Upvote 0
ai cho em hỏi tại sao code này không chạy khi cột a có "ok"
PHP Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:A")) Is Nothing Then
If UCase$(Target.Value) = "OK" Then
MyCode
ElseIf IsNumeric(Target.Value) Then
Else
End If
End If
End Sub


Code:
Sub MyCode()
MsgBox "Xin Chào"
End Sub
 
Upvote 0
Đó là macro sự kiện; Rõ hơn là bạn nhập gì đó vô cột [A]'

Nếu là dữ liệu kiểu số hay gì, gì khác thì nó iêm re; Bằng nhập "OK", "oK", "ok" hay "Ok" trong cột [A] thì nó sẽ báo bạn biết rằng bạn đã nhập 1 trong 4 từ đó trong ô vừa nhập.
 
Upvote 0
cho em hỏi, em đang tập tẹ VBA, em mún tách địa chỉ và đường ra bằng VBA phải viết thủ tục như thế nào ạ? bằng hàm thì em biết rồi ạ! Thanks!
Ví dụ như: 21 Nguyễn Hồng Đào ạ!
 
Upvote 0
HYen17 đã viết:
Đó là macro sự kiện; Rõ hơn là bạn nhập gì đó vô cột [A]'

Nếu là dữ liệu kiểu số hay gì, gì khác thì nó iêm re; Bằng nhập "OK", "oK", "ok" hay "Ok" trong cột [A] thì nó sẽ báo bạn biết rằng bạn đã nhập 1 trong 4 từ đó trong ô vừa nhập.
Nhấp chuột vào đây để mở rộng...

vba đó là đúng ý mình nhưng sao mình copy vào file nhap ok vào cột a
thì không thấy hiện thông báo của code msgbox
 
Upvote 0
Nhờ các bác tạo giúp xem cái Marcro menu có chức nang như sau:


Em không biết gì về Marcro nên em đọc của bác hiểu không hết, em nhờ bác tạo giúp em cái Menu có các Sheet và nội dung yêu cầu sau:
1. Em có 1 File có các Sheet tên là như sau: sheet tên là "Menu" (đây là Sheet chính để mở các Sheet khác), LENHXE_DIEUXE, SOQUY_THU_CHI, INLICHXE_DEDIEUXE, LICHXE_HANGNGAY, THUTIEN_KH_HANGNGAY, TT_NCC_HANGNGAY, DS_KH_NCC, LXE_THU_KH, LXE_NOP_TIEN, LXE_UNG, LXEDA_CHIPHI, CHILUONG_NV, LUONG_LXE, NCC_CON_NO, CONGNO_DATT_NCC, CONGNO_NCC, KH_CON_NO, CONGNO_TUNG_KH, DS_LXECTY
(tất các Sheet phụ trên ở ô A1 có Nút "Trở Về" khi Click vào sẽ trở lại về Sheet "Menu" - Trên Sheet "Menu" có tên các Sheet trên và khi Click vào tên nào sẽ mở Sheet đó).
Nhờ các giúp em làm cái cái Marcro để có chức năng như trên giúp. Cảm ơn bác nhiều.
 
Upvote 0
tonnydung đã viết:
Nhờ các bác tạo giúp xem cái Marcro menu có chức nang như sau:


Em không biết gì về Marcro nên em đọc của bác hiểu không hết, em nhờ bác tạo giúp em cái Menu có các Sheet và nội dung yêu cầu sau:
1. Em có 1 File có các Sheet tên là như sau: sheet tên là "Menu" (đây là Sheet chính để mở các Sheet khác), LENHXE_DIEUXE, SOQUY_THU_CHI, INLICHXE_DEDIEUXE, LICHXE_HANGNGAY, THUTIEN_KH_HANGNGAY, TT_NCC_HANGNGAY, DS_KH_NCC, LXE_THU_KH, LXE_NOP_TIEN, LXE_UNG, LXEDA_CHIPHI, CHILUONG_NV, LUONG_LXE, NCC_CON_NO, CONGNO_DATT_NCC, CONGNO_NCC, KH_CON_NO, CONGNO_TUNG_KH, DS_LXECTY
(tất các Sheet phụ trên ở ô A1 có Nút "Trở Về" khi Click vào sẽ trở lại về Sheet "Menu" - Trên Sheet "Menu" có tên các Sheet trên và khi Click vào tên nào sẽ mở Sheet đó).
Nhờ các giúp em làm cái cái Marcro để có chức năng như trên giúp. Cảm ơn bác nhiều.
Nhấp chuột vào đây để mở rộng...

Muốn làm thì bạn gởi file lên, mọi người mới giúp được.
 
Upvote 0
tonnydung đã viết:
Em gui anh, nho anh giup em voi
Nhấp chuột vào đây để mở rộng...

Cái này sao bạn không dùng Hyperlink?
1/ Tôi làm cho bạn bằng Click chuột phải vào 1 ô trong cột B sheet Menu (B1:B19)
2/ Nếu bạn muốn xài mấy cái Button thì làm theo như sau:
- Vào thẻ Developer, bấm nút Design mode
- Click đúp vào nút LICH XE DIEU XE, sẽ xuất hiện cái này trong VBE
Private Sub CommandButton1_Click()

End Sub
Nhấp chuột vào đây để mở rộng...
- Bạn nhập dòng lệnh này vào giữa, thành như vầy:
Private Sub CommandButton1_Click()
Sheets("LICHXE_DIEUXE").Activate
End Sub
Nhấp chuột vào đây để mở rộng...
Chú ý là "LICHXE_DIEUXE" phải đúng tên sheet muốn mở.
- Trở ra sheet Menu, click vào nút Design mode. Xong. Bạn click thử vào nút mới làm xem có chạy đến sheet "LICHXE_DIEUXE" không.
3/ Làm tương tự cho hết mấy chục cái nút của bạn.
4/ Insert 1 Module mới, Copy cái này vào:
Public Sub BackMe()
Sheets("Menu").Activate
End Sub
Nhấp chuột vào đây để mở rộng...
5/ Trong các sheet con (ngoài Menu), Bạn cũng vào Design mode, click đúp vào nút Trở về, bạn nhập "BackMe" dòng giữa
Private Sub CommandButton1_Click()
BackMe
End Sub
Nhấp chuột vào đây để mở rộng...
6/ Nhớ thoát khỏi chế độ Design mode khi làm xong.
 

File đính kèm

Upvote 0
Có ae nào biết vẽ biểu đồ đường bằng VBA ko?? do dữ liệu của mình luôn thay đổi và công việc lặp lại nên mình muốn tạo Marcro vẽ biểu đồ mà ko biết làm như thế nào?? tạo marcro cứ báo lỗi hoài @@
 
Upvote 0
marclight đã viết:
Có ae nào biết vẽ biểu đồ đường bằng VBA ko?? do dữ liệu của mình luôn thay đổi và công việc lặp lại nên mình muốn tạo Marcro vẽ biểu đồ mà ko biết làm như thế nào?? tạo marcro cứ báo lỗi hoài @@
Nhấp chuột vào đây để mở rộng...
Dữ liệu thay đổi thì vẽ biểu đồ động, VBA làm cái gì? Hay muốn gì gì đó phải có file???
 
Upvote 0
Chào các AC. CHo e hỏi 1 chút là làm sao có thể cài đc phím ( Ví dụ phím F5 ) cho 1 Macro, thông thường thì chỉ cài đc THeo kiểu Ctrl + ... hoặc Ctrl + Shirt + ... chứ ạ !
 
Upvote 0
keke355992 đã viết:
Chào các AC. CHo e hỏi 1 chút là làm sao có thể cài đc phím ( Ví dụ phím F5 ) cho 1 Macro, thông thường thì chỉ cài đc THeo kiểu Ctrl + ... hoặc Ctrl + Shirt + ... chứ ạ !
Nhấp chuột vào đây để mở rộng...
Bạn dùng thử lệnh này cho Moduble. Lưu lại đóng tập tin sau đó mở lại và nhấn phím F5 xem có gì lạ không?
Mã: 
Private Sub Auto_Open()
Application.OnKey "{F5}", "GPE"
End Sub
Private Sub Auto_Close()
    Application.OnKey "{F5}"
End Sub
Private Sub GPE()
    msgbox "Ban vua nhan phim F4"
End Sub
Có thể tham khảo ở đây:
https://msdn.microsoft.com/en-us/library/office/ff197461.aspx
 
Lần chỉnh sửa cuối:
Upvote 0
Chào các AC. CHo e hỏi 1 chút là làm sao có thể cài đc phím ( Ví dụ phím F5 ) cho 1 Macro, thông thường thì chỉ cài đc THeo kiểu Ctrl + ... hoặc Ctrl + Shirt + ... chứ ạ !
Nhấp chuột vào đây để mở rộng...

Bấm {CTRL}+{SHIFT}+F sẽ không tiện lợi bằng {F5}

Nhưng cái tiện lợi của bạn có thể là cái không tiện lợi cho người khác thì nên lưu í!

 
Upvote 0
HYen17 đã viết:
Bấm {CTRL}+{SHIFT}+F sẽ không tiện lợi bằng {F5}

Nhưng cái tiện lợi của bạn có thể là cái không tiện lợi cho người khác thì nên lưu í!
Nhấp chuột vào đây để mở rộng...
Thask a ạ, E đang học VBA nên mới tìm hiểu. Cứ mắc đến đâu lại hỏi đến đấy, mặc dù có thể ít ứng dụng, nhưng sẽ vận dụng đc vào nhìu cái mình cần ạ :) !
 
Upvote 0
giaiphap đã viết:
Bạn dùng thử lệnh này cho Moduble. Lưu lại đóng tập tin sau đó mở lại và nhấn phím F5 xem có gì lạ không?
Mã: 
Private Sub Auto_Open()
Application.OnKey "{F5}", "GPE"
End Sub
Private Sub Auto_Close()
    Application.OnKey "{F5}"
End Sub
Private Sub GPE()
    msgbox "Ban vua nhan phim F4"
End Sub
Có thể tham khảo ở đây:
https://msdn.microsoft.com/en-us/library/office/ff197461.aspx
Nhấp chuột vào đây để mở rộng...
E làm đc rùi ạ. thanks a :)
 
Upvote 0
Ba Tê đã viết:
Cái này sao bạn không dùng Hyperlink?
1/ Tôi làm cho bạn bằng Click chuột phải vào 1 ô trong cột B sheet Menu (B1:B19)
2/ Nếu bạn muốn xài mấy cái Button thì làm theo như sau:
- Vào thẻ Developer, bấm nút Design mode
- Click đúp vào nút LICH XE DIEU XE, sẽ xuất hiện cái này trong VBE

- Bạn nhập dòng lệnh này vào giữa, thành như vầy:

Chú ý là "LICHXE_DIEUXE" phải đúng tên sheet muốn mở.
- Trở ra sheet Menu, click vào nút Design mode. Xong. Bạn click thử vào nút mới làm xem có chạy đến sheet "LICHXE_DIEUXE" không.
3/ Làm tương tự cho hết mấy chục cái nút của bạn.
4/ Insert 1 Module mới, Copy cái này vào:

5/ Trong các sheet con (ngoài Menu), Bạn cũng vào Design mode, click đúp vào nút Trở về, bạn nhập "BackMe" dòng giữa

6/ Nhớ thoát khỏi chế độ Design mode khi làm xong.
Nhấp chuột vào đây để mở rộng...

Tks bác nhiều nhé, em làm được rồi.
 
Upvote 0
Ba Tê đã viết:
Cái này sao bạn không dùng Hyperlink?
1/ Tôi làm cho bạn bằng Click chuột phải vào 1 ô trong cột B sheet Menu (B1:B19)
2/ Nếu bạn muốn xài mấy cái Button thì làm theo như sau:
- Vào thẻ Developer, bấm nút Design mode
- Click đúp vào nút LICH XE DIEU XE, sẽ xuất hiện cái này trong VBE

- Bạn nhập dòng lệnh này vào giữa, thành như vầy:

Chú ý là "LICHXE_DIEUXE" phải đúng tên sheet muốn mở.
- Trở ra sheet Menu, click vào nút Design mode. Xong. Bạn click thử vào nút mới làm xem có chạy đến sheet "LICHXE_DIEUXE" không.
3/ Làm tương tự cho hết mấy chục cái nút của bạn.
4/ Insert 1 Module mới, Copy cái này vào:

5/ Trong các sheet con (ngoài Menu), Bạn cũng vào Design mode, click đúp vào nút Trở về, bạn nhập "BackMe" dòng giữa

6/ Nhớ thoát khỏi chế độ Design mode khi làm xong.
Nhấp chuột vào đây để mở rộng...

Em làm được rồi nhưng khi lưu lại và đóng file rồi mở lại thì click vào không có hiệu ứng gì nữa bác ah ?
 
Upvote 0
Mình muốn nhờ các cao thủ trên diễn đàn giúp mình với. Mình thường xuyên phải nhập liệu vào các file phức tạp như file 2 (gửi kèm), nhất là các sheet màu đỏ từ các file dạng như file 1. Có cách nào làm cho nhanh không các bác ơi. Trân trọng!
 
Upvote 0
bkphong đã viết:
Mình muốn nhờ các cao thủ trên diễn đàn giúp mình với. Mình thường xuyên phải nhập liệu vào các file phức tạp như file 2 (gửi kèm), nhất là các sheet màu đỏ từ các file dạng như file 1. Có cách nào làm cho nhanh không các bác ơi. Trân trọng!
Nhấp chuột vào đây để mở rộng...

qua đây xem bài giải nè

http://www.giaiphapexcel.com/forum/showthread.php?112024-Tạo-bảng-nhập-liệu-mới-từ-bảng-có-sẵn
 
Upvote 0
Em nhờ các bác giúp em đoạn Code VBA như sau:

1. Khi ngay nao nhap vao bat ky cot nao tu cot B2 den B6000 thi cot A2 den A6000 (khi nhap du lieu dong nao vao ngay nhap thi cot A se tu dong dien ngay thang ma nguoi nhap da nhap vao cot B
2. Các ô không có dữ liệu mới được nhập vào (các ô có dữ liệu thì khóa phải có pass mới sửa được) và khi nhập xong Save và đóng File lại thì tự động khóa tất cả các ô có dữ liệu và người dùng vẫn có thể lọc Filter được. Còn muốn sửa dữ liệu phải có Pass. Ngoài ra thêm chức năng khóa VA lại không cho người khác biết Code (vì họ biết sẽ sửa code thì code cua minh vô dụng).

Em có file attch kem theo nhờ các bác giúp. Tks
 

File đính kèm

Upvote 0
Lập trình VBA trên excell

Mình muốn hỏi các cao thủ giúp mình cho mình một ví dụ về lập trình VBA để: B1-Đầu tiên mình lập một mẫu bảng tính, B2- Mình nhập dữ liệu vào cột A,B,C bằng cách copy từ một file khác vào chẳng hạn, B3-Khi nhấn một nút insertform thì VBA tự động chèn vào từ cột D một bảng tính đã tạo từ bước 1 mỗi khi ở cột A có dữ liệu. Khi chèn hết các bảng tính thì chỉ cần ấn một nút Macro khác thì các giá trị ở cột B, C tự động điền vào bảng tính. Mình xin cảm ơn trước. Làm được thế thì việc tạo ra một loạt các bảng tính cùng mẫu rất nhanh và chuẩn xác.
 
Upvote 0
Do file xin được năng quá nên mình đành chụp ảnh gửi các bạn để thể hiện ý tưởng của trương trình.
 

File đính kèm

  • Chen bang.jpg
    Chen bang.jpg
    30.1 KB · Đọc: 47
Upvote 0
nhờ GPE giúp mình với.
Mã: 
public sub TinhTong(a as byte, b as byte)
tinhtong = a+b
end sub
một code khác như này thì bị báo lỗi
Mã: 
sub abc()
tinhtong(1[B],[COLOR=#ff0000]1[/COLOR][/B])
end sub
có gì sai trong chỗ in đậm màu đỏ đó không
 
Upvote 0
Mutants Men đã viết:
nhờ GPE giúp mình với.

Mã: 
sub abc()
tinhtong(1[B],[COLOR=#ff0000]1[/COLOR][/B])
end sub
có gì sai trong chỗ in đậm màu đỏ đó không
Nhấp chuột vào đây để mở rộng...

Bạn viết vầy dẫu nó có thông minh đến mấy cũng chẳng có thể hiểu được bạn đang muốn tính cái gì đâu
 
Upvote 0
Mutants Men đã viết:
nhờ GPE giúp mình với.
Mã: 
public sub TinhTong(a as byte, b as byte)
tinhtong = a+b
end sub
một code khác như này thì bị báo lỗi
Mã: 
sub abc()
tinhtong(1[B],[COLOR=#ff0000]1[/COLOR][/B])
end sub
có gì sai trong chỗ in đậm màu đỏ đó không
Nhấp chuột vào đây để mở rộng...

Bạn nên tìm hiểu về sự khác nhau giữa Sub và function; khi nào sử dụng chúng, có nhiều cách nhưng tạm sửa thế này :


Mã: 
public FunctionTinhTong(a as byte, b as byte)
tinhtong = a+b
end Function

Chạy sub Main này sẽ có kết quả
Mã: 
sub Main()
Msgbox tinhtong(1,1[COLOR=#ff0000][/COLOR])
end sub
 
Lần chỉnh sửa cuối:
Upvote 0
ppc0312 đã viết:
Bạn nên tìm hiểu về sự khác nhau giữa Sub và function; khi nào sử dụng chúng, có nhiều cách nhưng tạm sửa thế này :


Mã: 
public FunctionTinhTong(a as byte, b as byte)
tinhtong = a+b
end Function

Chạy sub Main này sẽ có kết quả
Mã: 
sub Main()
Msgbox tinhtong(1,1)
end sub
Nhấp chuột vào đây để mở rộng...

cảm ơn bạn, nhưng mình biết sự khác nhau giữa sub và function.
nhưng public sub TinhTong chỉ là ví dụ 1 phần thôi.
bê trong nội dung nó còn xử lý nhiều cái lắm chứ không đơn thuần là tinhtong = a+b
vậy public sub chỉ có được 1 tham chiếu thôi hay sao.
--------------------------------
sẵn cho mình hỏi thêm. không biết do mình chỉnh sửa cái gì mà có 1 đoạn code trước kia chạy ok mà đột nhiên hôm nay chạy lại bị sai
Mã: 
redim Arr(1 to 10, 1 to 2)
..... truyền dữ liệu vào mảng Arr.....
cells(1,1).resize(10,2)= Arr '<= bị cái này, không hiểu sao nó không điền vào hết  mà chỉ điền được mỗi dòng đầu tiên
trong khi mình viết như này thì điền hết nội dung vào mảng được
range("A1:B10")=Arr
 
Upvote 0
Mutants Men đã viết:
cảm ơn bạn, nhưng mình biết sự khác nhau giữa sub và function.
nhưng public sub TinhTong chỉ là ví dụ 1 phần thôi.
bê trong nội dung nó còn xử lý nhiều cái lắm chứ không đơn thuần là tinhtong = a+b
vậy public sub chỉ có được 1 tham chiếu thôi hay sao.
Nhấp chuột vào đây để mở rộng...

Người ta đã khuyên tìm hiểu thêm thì chịu khó tìm hiểu đi.
Chẳng những bạn không biết phân biệt sub/function mà bạn cũng chẳng biết cách gọi sub/function. Tìm hiểu thêm về cách gọi đi.

Mutants Men đã viết:
sẵn cho mình hỏi thêm. không biết do mình chỉnh sửa cái gì mà có 1 đoạn code trước kia chạy ok mà đột nhiên hôm nay chạy lại bị sai
Mã: 
redim Arr(1 to 10, 1 to 2)
..... truyền dữ liệu vào mảng Arr.....
cells(1,1).resize(10,2)= Arr '<= bị cái này, không hiểu sao nó không điền vào hết  mà chỉ điền được mỗi dòng đầu tiên
trong khi mình viết như này thì điền hết nội dung vào mảng được
range("A1:B10")=Arr
Nhấp chuột vào đây để mở rộng...

Một việc chưa xong. Hỏi thêm việc thứ 2 làm sao mà tiêu nỗi.
 
Upvote 0
Hi ac, hiện e cần đang tổng hợp dữ liệu từ file này sang file khác nhưng mà hem rành về VBA lắm nên nhờ ac chỉ giáo giúp với ạ, e cám ơn ac trước nha.

Cụ thể như sau: lấy dữ liệu từ file NGUON DL sang file KET QUA theo TARGET và MS.

Trong đó

file NGUON DL chứa điều kiện lọc là ô A1 (ô A1 có định dạng giống nhau giữa các sheet, riêng có 2 sheet cuối cùng khác định dạng và không cần lấy dl *lưu ý: số lượng các sheet sẽ thay đổi, ko cố định*) và cột MS (có nhiều MS nhưng chỉ lọc những MS nào có trong sheet DK của file KET QUA),

file KET QUA chứa 2 sheet: 1 sheet là final (lọc dữ liệu từ file NGUON DL thỏa điều kiện trong sheet DK rùi copy vào sheet final) , 1 sheet là DK chứa điều kiện (MS và TARGET) cần lấy dữ liệu

e có đính kèm file để mô tả, ac xem giúp giúp e vs
 

File đính kèm

Upvote 0
Đây là đoạn code em sưu tầm được trên GPE

[GPECODE=sql]Sub GhiDL_HLMT() Dim cn As Object
Set cn = CreateObject("ADODB.Connection")
With cn
.ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"data source=" & ThisWorkbook.Path & _
"\B.xls;extended properties=""excel 8.0;HDR=Yes;"";"
.Open
.Execute "INSERT INTO [Data$] SELECT STT,TEN,SL FROM [excel 8.0;database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Sheet1$B8:D23]"
End With
cn.Close: Set cn = Nothing
End Sub[/GPECODE]


Cho em hỏi làm cách nào để có thể xóa dữ liệu đã ghi vô Sheet B trước đó, sau đó mới cập nhật dữ liệu mới khi thực hiện đoạn code trên
Trân trọng cảm ơn
 
Lần chỉnh sửa cuối:
Upvote 0
huuduy.duy đã viết:
Đây là đoạn code em sưu tầm được trên GPE

[GPECODE=sql]Sub GhiDL_HLMT() Dim cn As Object
Set cn = CreateObject("ADODB.Connection")
With cn
.ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"data source=" & ThisWorkbook.Path & _
"\B.xls;extended properties=""excel 8.0;HDR=Yes;"";"
.Open
.Execute "INSERT INTO [Data$] SELECT STT,TEN,SL FROM [excel 8.0;database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Sheet1$B8:D23]"
End With
cn.Close: Set cn = Nothing
End Sub[/GPECODE]


Cho em hỏi làm cách nào để có thể xóa dữ liệu đã ghi vô Sheet B trước đó, sau đó mới cập nhật dữ liệu mới khi thực hiện đoạn code trên
Trân trọng cảm ơn
Nhấp chuột vào đây để mở rộng...

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.
 
Upvote 0
Bị lỗi khi dùng 2 dictionary

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.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
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...
Phong thử bỏ Value đi xem như thế nào, bài này xài 1 Dic là được rồi.
 
Upvote 0
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...

Cái dòng màu đỏ phải bẫy lỗi thêm:
If Not dic2.exists(Cells(j, 1).Value) Then dic2.Add Cells(j, 1).Value, ""
Lý do, ví dụ tên Tuấn, dic1 sẽ có Tiền Giang - Huế.
dic2 add Hà Nội ở A2 và A6, trùng Key ---> Lỗi
 
Upvote 0
Excel khó quá đã viết:
ồ anh thật là giỏi , xin anh chỉ cho em biết cách tuyệt vời của anh cho em học với }}}}}}}}}}
Nhấp chuột vào đây để mở rộng...

Bài này mình cũng viết được mà không cần dùng DIC mà:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1")) Is Nothing Then


Range("C2:C50").ClearContents
Dim i, j, k As Long
Dim cll As Range, vung
Set vung = Range("D1")


[COLOR=#ff0000][B]' Phan 1: Tao ra danh sách các tỉnh mà người có tên ở C1 đã từng đi[/B][/COLOR]
[COLOR=#008000]'=============================================[/COLOR]
For i = 2 To 8
  If Cells(i, 2).Value = Cells(1, 3).Value Then
    Set vung = Union(Range("A" & i), vung)
  End If
Next i


[COLOR=#ff0000][B]'Phan 2 : Lấy những tỉnh ở cột A mà không có trong danh sách vừa tạo ra[/B][/COLOR]
[COLOR=#008000]'=====================================================[/COLOR]=
k = 2
For j = 2 To 8
  cou = 0
  For Each cll In vung
    If cll.Value = Cells(j, 1).Value Then
      cou = cou + 1
    End If
  Next cll
  If cou = 0 Then
   Cells(k, 3).Value = Cells(j, 1).Value
   k = k + 1
  End If
Next j

[COLOR=#ff0000][B]'Phân 3: Loại bỏ các giá trị trùng nhau để ra kết quả cuối cùng[/B][/COLOR]
[COLOR=#008000]'=======================================================[/COLOR]
Range("C2:C" & [C100].End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
End If
End Sub

Nhưng vì nó hơi dài nên mình muốn chuyển qua dùng DIC cho ngắn hơn thôi
 
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Cái dòng màu đỏ phải bẫy lỗi thêm:
If Not dic2.exists(Cells(j, 1).Value) Then dic2.Add Cells(j, 1).Value, ""
Lý do, ví dụ tên Tuấn, dic1 sẽ có Tiền Giang - Huế.
dic2 add Hà Nội ở A2 và A6, trùng Key ---> Lỗi
Nhấp chuột vào đây để mở rộng...

Cám ơn thầy BATE ạ, nhờ thầy mách nước con đã biết cách khắc phục rồi:
PHP: 
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 = Cells(1, 3).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) And Not dic2.exists(Cells(j, 1).Value) Then
    dic2.Add Cells(j, 1).Value, ""
  End If
Next j
'==========================================================
  Range("C2").Resize(dic2.Count) = WorksheetFunction.Transpose(dic2.keys)
End If
End Sub

Cám ơn mọi người đã tham gia trả lời giúp em ạ ! Làm ra được cái zui thiệt á ...--=0--=0.
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn chỉ cần key chứ không cần giá trị item, cho nên có thể dùng thẳng lệnh ghi trị cho key, thay vì add key. Như vậy không phải kiểm tra key có hay chưa. Nếu có rồi thì nó sửa item, nếu chưa thì nó thêm key vào.

If Not dic1.exists(Cells(j, 1).Value) Then dic2(Cells(j, 1).Value) = ""

Tuy nhiên, bài này nếu muốn dùng 2 đit thì tôi cũng chỉ đọc mảng 1 lần thôi, ghi cả 2 đít 1 lúc.
Sau đó dùng vòng lặp đọc từng phần tử bên đít 1 và trừ ra khỏi đít 2
 
Lần chỉnh sửa cuối:
Upvote 0
khuongvietphong đã viết:
Bài này mình cũng viết được mà không cần dùng DIC mà:
Mã: 
Nhưng vì nó hơi dài nên mình muốn chuyển qua dùng DIC cho ngắn hơn thôi[/QUOTE]

bài này bạn có nhu cầu lọc duy nhất, xài dic là nhất rồi, 
xin lổi vì tôi đọc ko kỹ yêu cầu
nhưng vì lỡ nói ko xài dic, góp thêm bạn đoạn code cho vui
[code]
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim data As Variant
Dim result(1 To 8)
Dim i, k As Long
data = [a2:b8]
If Target.Address = "$C$1" Then
  For i = 1 To UBound(data)
    If data(i, 2) <> "" And data(i, 2) <> [c1] Then
    
            If TypeName(Application.Match(data(i, 1), result, 0)) = "Error" Then
                k = k + 1
                result(k) = data(i, 1)
            End If
   
    End If
Next
End If
  
 If k Then
  [c2:c8].ClearContents
  [c2].Resize(k) = Application.Transpose(result)
End If
End Sub
kè kè.......vẫn chưa ổn.......
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
Let'GâuGâu đã viết:
bài này bạn có nhu cầu lọc duy nhất, xài dic là nhất rồi,
xin lổi vì tôi đọc ko kỹ yêu cầu
nhưng vì lỡ nói ko xài dic, góp thêm bạn đoạn code cho vui
Mã: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim data As Variant
Dim result(1 To 8)
Dim i, k As Long
data = [a2:b8]
If Target.Address = "$C$1" Then
  For i = 1 To UBound(data)
    If data(i, 2) <> "" And data(i, 2) <> [c1] Then
    
            If TypeName(Application.Match(data(i, 1), result, 0)) = "Error" Then
                k = k + 1
                result(k) = data(i, 1)
            End If
   
    End If
Next
End If
  
 If k Then
  [c2:c8].ClearContents
  [c2].Resize(k) = Application.Transpose(result)
End If
End Sub
kè kè.......vẫn chưa ổn.......
Nhấp chuột vào đây để mở rộng...

Nếu tên tỉnh xảy ra trước tỉnh đi qua thì code này sai.

Bài này dùng 2 vòng lặp là đúng rồi. Dùng 1 vòng lặp cũng có thể được nhưng không giản dị như code trên đâu.
 
Upvote 0
VetMini đã viết:
Nếu tên tỉnh xảy ra trước tỉnh đi qua thì code này sai.

Bài này dùng 2 vòng lặp là đúng rồi. Dùng 1 vòng lặp cũng có thể được nhưng không giản dị như code trên đâu.
Nhấp chuột vào đây để mở rộng...

ra hàng xóm đánh cờ tướng, thua hoài, tức quá về viết code
nói chung là cho vui, chứ xài dic là tốt nhất
trong code này có lòng thêm một vòng lặp, cái này dùng mấy cái join, replace, split chắc cũng được
nhưng mà vợ bắt dọn dẹp nhà cửa, mệt quá.........hihihi
Mã: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim data, TP, Tng, kk As Variant
Dim i, k, J, ii As Long
Dim result(1 To 8), list(1 To 8)
data = [a2:b8]
If Target.Address = "$C$1" Then
  For i = 1 To UBound(data)
    If data(i, 2) <> "" Then
        kk = Application.Match(data(i, 1), result, 0)
        If data(i, 2) <> [c1] Then
            If TypeName(kk) = "Error" Then
                If TypeName(Application.Match(data(i, 1), list, 0)) = "Error" Then
                    k = k + 1
                    result(k) = data(i, 1)
                End If
            Else
            End If
        Else
            J = J + 1
            list(J) = data(i, 1)
            If TypeName(kk) <> "Error" Then
                For ii = kk To UBound(result) - 1
                    If result(ii) = "" Then Exit For
                    result(ii) = result(ii + 1)
                Next
                k = k - 1
            End If
        End If
    End If
Next
End If
  
 If k Then
  [c2:c8].ClearContents
  [c2].Resize(k) = Application.Transpose(result)
End If
End Sub
chúc bà con ăn tết vui
 
Lần chỉnh sửa cuối:
Upvote 0
Let'GâuGâu đã viết:
ra hàng xóm đánh cờ tướng, thua hoài, tức quá về viết code
nói chung là cho vui, chứ xài dic là tốt nhất
trong code này có lòng thêm một vòng lặp, cái này dùng mấy cái join, replace, split chắc cũng được
nhưng mà vợ bắt dọn dẹp nhà cửa, mệt quá.........hihihi
Mã: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim data, TP, Tng, kk As Variant
Dim i, k, J, ii As Long
Dim result(1 To 8), list(1 To 8)
data = [a2:b8]
If Target.Address = "$C$1" Then
  For i = 1 To UBound(data)
    If data(i, 2) <> "" Then
        kk = Application.Match(data(i, 1), result, 0)
        If data(i, 2) <> [c1] Then
            If TypeName(kk) = "Error" Then
                If TypeName(Application.Match(data(i, 1), list, 0)) = "Error" Then
                    k = k + 1
                    result(k) = data(i, 1)
                End If
            Else
            End If
        Else
            J = J + 1
            list(J) = data(i, 1)
            If TypeName(kk) <> "Error" Then
                For ii = kk To UBound(result) - 1
                    If result(ii) = "" Then Exit For
                    result(ii) = result(ii + 1)
                Next
                k = k - 1
            End If
        End If
    End If
Next
End If
  
 If k Then
  [c2:c8].ClearContents
  [c2].Resize(k) = Application.Transpose(result)
End If
End Sub
chúc bà con ăn tết vui
Nhấp chuột vào đây để mở rộng...

ai biễu lấy vợ chi cho bị bắt dọn nhà , ha ha
xĩn có cách làm của người xĩn , ặc ặc

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cn As Object
If Target.Address = "$C$1" Then
    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"";"
    Sheet1.Range("C2:C8").ClearContents
    Sheet1.Range("C2").CopyFromRecordset cn.Execute("select distinct b.f1 from (select * from [sheet1$A2:B8] " & _
    " where f2 = '" & Target.Value & "') a right join (select * from [sheet1$A2:B8]) b " & _
    " on a.f1 = b.f1 where a.f1 is null")
    cn.Close
    Set cn = Nothing
End If
End Sub
 
Upvote 0
doveandrose đã viết:
ai biễu lấy vợ chi cho bị bắt dọn nhà , ha ha
xĩn có cách làm của người xĩn , ặc ặc

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cn As Object
If Target.Address = "$C$1" Then
    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"";"
    Sheet1.Range("C2:C8").ClearContents
    Sheet1.Range("C2").CopyFromRecordset cn.Execute("select distinct b.f1 from (select * from [sheet1$A2:B8] " & _
    " where f2 = '" & Target.Value & "') a right join (select * from [sheet1$A2:B8]) b " & _
    " on a.f1 = b.f1 where a.f1 is null")
    cn.Close
    Set cn = Nothing
End If
End Sub
Nhấp chuột vào đây để mở rộng...

cái này là hàng "xa xí phẩm" đối với mình rồi.........hihihiih
dòng lệnh này có nghĩa gì vậy đại ca?
Mã: 
Sheet1.Range("C2").CopyFromRecordset cn.Execute("select distinct b.f1 from (select * from [sheet1$A2:B8] " & _
    " where f2 = '" & Target.Value & "') [COLOR=#ff0000]a right join (select * from [sheet1$A2:B8]) b " & _
    " on a.f1 = b.f1 where a.f1 is null")[/COLOR]
2 câu trên thì hiểu chọn duy nhất ở cột 1, chọn cột 2 bằng target.value, còn đoạn jion này thì ko hiểu
mong đai ca giải thích với
nếu hiểu sẻ đa tạ một bao lì xì của con tui nha...hhihihi
===========
đọc cứ như đọc bùa "bát quái"....hihihi
tức là lấy cột 1 ghép với cột 2, chổ nào mà nó có giá trị = ô C1
nhưng còn khúc cuối là gì?
on a.f1 = b.f1 where a.f1 is null"
 
Lần chỉnh sửa cuối:
Upvote 0
khuongvietphong đã viết:
Bài này mình cũng viết được mà không cần dùng DIC mà:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1")) Is Nothing Then


Range("C2:C50").ClearContents
Dim i, j, k As Long
Dim cll As Range, vung
Set vung = Range("D1")


[COLOR=#ff0000][B]' Phan 1: Tao ra danh sách các tỉnh mà người có tên ở C1 đã từng đi[/B][/COLOR]
[COLOR=#008000]'=============================================[/COLOR]
For i = 2 To 8
  If Cells(i, 2).Value = Cells(1, 3).Value Then
    Set vung = Union(Range("A" & i), vung)
  End If
Next i


[COLOR=#ff0000][B]'Phan 2 : Lấy những tỉnh ở cột A mà không có trong danh sách vừa tạo ra[/B][/COLOR]
[COLOR=#008000]'=====================================================[/COLOR]=
k = 2
For j = 2 To 8
  cou = 0
  For Each cll In vung
    If cll.Value = Cells(j, 1).Value Then
      cou = cou + 1
    End If
  Next cll
  If cou = 0 Then
   Cells(k, 3).Value = Cells(j, 1).Value
   k = k + 1
  End If
Next j

[COLOR=#ff0000][B]'Phân 3: Loại bỏ các giá trị trùng nhau để ra kết quả cuối cùng[/B][/COLOR]
[COLOR=#008000]'=======================================================[/COLOR]
Range("C2:C" & [C100].End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
End If
End Sub

Nhưng vì nó hơi dài nên mình muốn chuyển qua dùng DIC cho ngắn hơn thôi
Nhấp chuột vào đây để mở rộng...

Không dùng Dic, có thể so sánh chuỗi để làm.
Thất nghiệp làm thử:
PHP: 
Public Sub GPE()
Dim sArr(), dArr(), I As Long, K As Long, L As Long, DK As String, Tem As String
sArr = Range("A2:B8").Value
L = UBound(sArr)
DK = Range("C1").Value
ReDim dArr(1 To L, 1 To 1)
For I = 1 To L
    If sArr(I, 2) = DK Then Tem = Tem & "#" & sArr(I, 1)
Next I
For I = 1 To L
    If InStr(Tem, sArr(I, 1)) = 0 Then
        Tem = Tem & "#" & sArr(I, 1)
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
    End If
Next I
Range("C2").Resize(K) = dArr
End Sub
 
Upvote 0
Ba Tê đã viết:
Không dùng Dic, có thể so sánh chuỗi để làm.
Thất nghiệp làm thử:
PHP: 
Public Sub GPE()
Dim sArr(), dArr(), I As Long, K As Long, L As Long, DK As String, Tem As String
sArr = Range("A2:B8").Value
L = UBound(sArr)
DK = Range("C1").Value
ReDim dArr(1 To L, 1 To 1)
For I = 1 To L
    If sArr(I, 2) = DK Then Tem = Tem & "#" & sArr(I, 1)
Next I
For I = 1 To L
    If InStr(Tem, sArr(I, 1)) = 0 Then
        Tem = Tem & "#" & sArr(I, 1)
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
    End If
Next I
Range("C2").Resize(K) = dArr
End Sub
Nhấp chuột vào đây để mở rộng...
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)
 
Upvote 0
Let'GâuGâu đã viết:
...
nhưng còn khúc cuối là gì?
on a.f1 = b.f1 where a.f1 is null"
Nhấp chuột vào đây để mở rộng...

Đó là cái mẹo để trừ phần tử của tập hợp B ra phỏi tập hợp A (tìm A - B). Thường thì người ta dùng Left Join, dễ hiểu hiơn Right Join.
Lý thuyết: nếu A left/Right join B thì kết quả sẽ gồm tất cả những phần tử A trong 2 trạng thái:
Những phần tử trong A và có trong B sẽ mang dữ liệu của B
Những phần tử trong A nhưng khong có trong B sẽ có phần tương ứng B là null (vì có đâu mà đưa ra)
Như vậy, trong cái kết quả left/right join này, nếu ta lượt ra những dòng có B là null thì sẽ được tập hợp A - B

Lưu ý rằng đây là mẹo tốc độ. Vì đối với tất cả phiên bản SQL, lệnh join thường là lệnh được xử lý rất nhanh.
Nếu làm theo đúng chuẩn thì thực ra SQL có lệnh NOT EXISTS để thực hiện tính trừ tập hợp.
(còn có 1 lệnh nữa là NOT IN)

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...

1 vòng lặp thì khá rắc rối cho nên có thể chóng mặt hơn.
Cụ thể 1 cách, tôi có thể đọc dữ liệu, nhét vào một chuỗi, đồng thời nhét phần ngoại lệ vào một mẫu RegEx
Sau khi hết vòng lặp tôi chỉ việc gọi RegEx ra replace mẫu.
 
Upvote 0
VetMini đã viết:
Đó là cái mẹo để trừ phần tử của tập hợp B ra phỏi tập hợp A (tìm A - B). Thường thì người ta dùng Left Join, dễ hiểu hiơn Right Join.
Lý thuyết: nếu A left/Right join B thì kết quả sẽ gồm tất cả những phần tử A trong 2 trạng thái:
Những phần tử trong A và có trong B sẽ mang dữ liệu của B
Những phần tử trong A nhưng khong có trong B sẽ có phần tương ứng B là null (vì có đâu mà đưa ra)
Như vậy, trong cái kết quả left/right join này, nếu ta lượt ra những dòng có B là null thì sẽ được tập hợp A - B

Lưu ý rằng đây là mẹo tốc độ. Vì đối với tất cả phiên bản SQL, lệnh join thường là lệnh được xử lý rất nhanh.
Nếu làm theo đúng chuẩn thì thực ra SQL có lệnh NOT EXISTS để thực hiện tính trừ tập hợp.
(còn có 1 lệnh nữa là NOT IN)
Nhấp chuột vào đây để mở rộng...


í anh Vetmini đã trúng bao lì xì của Let' Gâu Gâu kìa . hi hi
có lần em đã thay lệnh Join On where is null bởi lệnh Not IN và kết quả là từ đó em đã tự hứa với lòng sẽ dẹp lệnh NOT IN mãi mãi khỏi đầu óc ....
chúc anh Vetmini năm mới vui vẻ nha .
 
Upvote 0
Cách thứ 2, so sánh chuỗi và dùng 1 vòng lặp. Gọi các tỉnh là loại 1, các tỉnh đi qua là loại 2.
Vòng lặp đọc, nếu gặp loại 2 thì nhét vào chuỗi loại 2 và trừ ra khỏi chuỗi loại 1. Nếu gặp loại 1 thì xét xem nó có trong chuỗi loại 2, nếu không có thì nhét vào chuỗi loại 1.

Thực ra cách 2 tập dữ liệu chạy song song như thế này làm dic hay chuỗi đều được (như tôi đã có nói qua). Chỉ có phần trừ ra, được tô đỏ ở trên nó hơi rắc rối 1 chút.
 
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...

Chưa tới năm con Khỉ, nhưng làm thí thí kiểu "Con Khỉ" cho "Đại Ca" "dzừa bụng".
PHP: 
Public Sub GPE_2()
Application.ScreenUpdating = False
Dim Rng As Range, Cll As Range
Range("A2:A8").Offset(, 2).Value = Range("A2:A8").Value
Set Rng = Range("B2:B8")
For Each Cll In Rng
    If Cll.Value = Range("C1").Value Then Rng.Offset(, 1).Replace What:=Cll.Offset(, 1), Replacement:=""
Next
Rng.Offset(, 1).RemoveDuplicates Columns:=1
Rng.Offset(, 1).Sort Key1:=Range("C2") 'Híc! Hổng biết làm sao cho nó dồn lên dòng đầu'
Set Rng = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
í anh Vetmini đã trúng bao lì xì của Let' Gâu Gâu kìa . hi hi
có lần em đã thay lệnh Join On where is null bởi lệnh Not IN và kết quả là từ đó em đã tự hứa với lòng sẽ dẹp lệnh NOT IN mãi mãi khỏi đầu óc ....
chúc anh Vetmini năm mới vui vẻ nha .
Nhấp chuột vào đây để mở rộng...

Not In bị vấn đề khi dữ liệu có Null. Cách làm tôi muốn đưa ra nếu bảo đảm không có Null thì không sao cả.

From A where A.f1 NOT IN (select f1 From B where B.f2 = caiGiDo) -- nếu trong subquery có Null thì sẽ ra sai

From A where NOT EXISTS (select * From B where B.f1 = A.f1 And B.f2 = caiGiDo)
 
Upvote 0
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
hpkhuong đã viết:
Tôi mở file lên thấy bình thường. Có lỗi gì đâu nhỉ???
Nhấp chuột vào đây để mở rộng...

muốn thấy lỗi ư ? để tôi giúp cho thấy
1/check như hình dưới đây

c73afb1281f4c3f1b220cd78a450121a.png

2/bấm nút tải file ở trên vài lần
3/mở cái file cuối cùng mới tải xuống
4/bấm nút Enable Editing

7a064d41a781d48e79eaf04c5246214a.png


thử xem =))
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

S
cần xử lý dữ liệu trùng nhau bằng VBA (4 người xem)
    • Cười
Trả lời
2
Đọc
16
SA_DQ
SA_DQ
N
Tạo file lưu trữ dữ liệu tự động trên excel.
Trả lời
7
Đọc
100
le_vis
L
N
  • Question Question
Tạo file lưu trữ dự liệu tự động
Trả lời
6
Đọc
119
Hoàng Tuấn 868
H
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
9
Đọc
505
ongke0711
ongke0711
Ả
Cách tạo list Data validation không qua trung gian (1 người xem)
Trả lời
45
Đọc
7K
HOADINH84
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
395
Đọc
47K
phamvanquoc.hanamninh
P
V
  • Question Question
Tạo dữ liệu random cho từng sheet dựa theo dữ liệu có sẵn (1 người xem)
Trả lời
3
Đọc
132
HieuCD
H
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết (5 người xem)
Trả lời
26
Đọc
25K
dungpham01
D
D
in ra bị thiếu chữ
Trả lời
4
Đọc
96
dankedun
D
Momominh
Hỏi công thức tìm tuần thiếu hàng
Trả lời
1
Đọc
75
hoangtuaotrang_hp_vn
H
2
EM MUỐN TẠO MA TRẬN BIẾN ĐỔI GIÁ TRỊ PHẦN TỬ NGẪU NHIÊN
Trả lời
2
Đọc
72
ptm0412
ptm0412
Emyeuexcel
Cộng 4 tuần theo 1 qui luật qui định
Trả lời
34
Đọc
2K
Emyeuexcel
Emyeuexcel
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb
Trả lời
6
Đọc
294
YêuCN
Y
S
Mở 2 cửa sổ riêng biệt
Trả lời
31
Đọc
24K
ThanhNgan240723
T
vn81206
TRA CỨU MÃ SỐ THUẾ CÁ NHÂN QUA EXCEL
    • Buồn
Trả lời
57
Đọc
20K
vovietdung261016
V
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ (1 người xem)
    • Thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
huuthang_bd
Add in SwitchSheet: Quay lại các sheet đã xem trước đó bằng phím tắt
    • Thích
    • Yêu thích
2
Trả lời
146
Đọc
43K
phong_codon
P
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
14
Đọc
613
Quang_Hải
Quang_Hải
N
Cài phần mềm đọc số ra chữ
Trả lời
2
Đọc
147
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
Em cần hỗ trợ tách nhiều file và đặt tên theo quy ước chung từ bảng 01 excel có sẳng
Trả lời
1
Đọc
127
HUONGHCKT
H
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom