Đố vui về VBA!

Liên hệ QC
anhtuan1066

anhtuan1066

Thành viên gạo cội
Tham gia
10/3/07
Bài viết
5,802
Được thích
6,905
Nhằm cũng cố kiến thức về VBA cho các bạn mới bắt đầu và cả những bạn đang ứng dụng mà chưa hiểu nhiều về nó, tôi mở topic này với mong mõi qua những câu hỏi vui, các bạn sẽ nhận định lại sự hiểu biết cũa mình... (Kễ cã chính tôi cũng đang tập tành nên có rất nhiều cái chưa biết)
Mong rằng topic sẽ mang đến cho các bạn những khám phá thú vị với những cái tưỡng chừng như đã biết
Mong nhận dc bài viết về câu đố cũa các cao thủ! Còn các bạn mới thì đừng ngại khi đưa ra ý kiến cũa mình.. Có sai có sữa sẽ hoàn thiện!
Tôi xin mỡ màn trước bằng 1 câu hỏi đơn giãn
ANH TUẤN

CÂU HỎI 1: Tại sao biến K ko hoạt động?
Tôi muốn khi nhấn vào 1 button thì cell A1 sẽ tăng lên 1 đơn vị... Tôi đã làm như sau:
-Tạo 1 Command Button (nút nhấn thuộc thanh Control Toolbox), click phải chuột lên nút nhấn, chọn View code, rồi gõ vào đoạn code sau:
PHP: 
Private Sub CommandButton1_Click()
   K = K + 1
   Range("A1").Value = K
End Sub
Ban đầu K chưa có gì, xem như =0, nhấn nút lần thứ nhất thì K dc tăng thêm 1, vậy K hiện tại sẽ bằng 1, và gán K vào cell A1 thì đương nhiên A1 sẽ =1... Nhấn nút lần 2, K lại dc tăng thêm 1 nên hiện tại K sẽ =2 và cell A1 cũng sẽ =2... vân vân.. từ đó diễn tiến tiếp...
Hi.. hi.. Điều này nghe qua có vẽ rất hợp lý, ấy thế mà khi nhấn nút nó chỉ hoạt động dc duy nhất 1 lần (A1 = 1) rồi thôi ko nhút nhít nữa...
Các bạn có thể giãi thích tại sao lại như thế ko? Tại sao những lần nhấn nút sau đó K lại ko tăng thêm tí nào (vì thực tế A1 vẫn cứ = 1 hoài) ?
ANH TUẤN
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
ExecQuery là 1 phương thức nằm trong cái không gian danh phận (namespace) của \root\CIMV2\
namespace là vùng dùng để phân biệt tên biến, thuộc tính, và phương thức (cũng như folders, 2 files tên giống nhau không thể nằm cùng folder, nhưng khác folder thì vô tư)
Trong trường hợp này, winmgmts không có phương thức nào khác trùng tên cho nên scripting engine tự động nối tiền tố mặc định cho phương thức. Ta có thể nói, có hay không có cũng được.
Lưu ý là winmgmts có thể được gọi cho máy khác cùng mạng (nếu script được cho phép).

@AutoReply:
"gõ đầu 3 cái không phải để khen hay chửi , mà để kiểm tra độ cứng của cái đầu --=0--=0"
Lúc đưa ra câu đố "không được quẳng lên trời, không liệng xuống đất" thì Bồ đề đã kiểm tra Hầu vương xong rồi (tuy theo quan niệm triết mà người có thể lý luận đây là kiểm tra trí tuệ hay nhân phẩm)
Khi gõ đầu, Bồ đề không cần kiểm tra Hầu vương thêm nữa. Nếu chịu khó đọc truyện cho kỹ thì đã biết đấy là một ám hiệu.
 
Upvote 0
Cuối tuần giải trí chút nha các bạn.
Nhờ các bạn lấy dữ liệu từ file đang đóng data.xlsx tại những dòng có stt nằm giữa 100 và 1000
Mà không sử dụng các công cụ Vòng lặp , Filter , ADO
Khuyến khích "chơi thế lạ"
Cảm ơn các bạn
 

File đính kèm

  • dovui.rar
    664.9 KB · Đọc: 27
Upvote 0
AutoReply đã viết:
Cuối tuần giải trí chút nha các bạn.
Nhờ các bạn lấy dữ liệu từ file đang đóng data.xlsx tại những dòng có stt nằm giữa 100 và 1000
Mà không sử dụng các công cụ Vòng lặp , Filter , ADO
Khuyến khích "chơi thế lạ"
Cảm ơn các bạn
Nhấp chuột vào đây để mở rộng...
Mình đưa tạm đáp án bạn xem có được không nhé
Mã: 
Sub GetData()
    Dim Wb As Workbook
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Link As String
   
    Link = "D:\data.xlsx"
    Set Wb = Application.Workbooks.Open(Link)
    Set Sh = Wb.Sheets("sheet1")
    Sh.[C2:C100001].FormulaR1C1 = "=IF(AND(RC[-2]>100,RC[-2]<900),1,""NG"")"
    Set Rng = Sh.[C2:C100001].SpecialCells(xlCellTypeFormulas, 1)
    Range(Rng.Offset(, -2), Rng.Offset(, -1)).Copy
    ThisWorkbook.ActiveSheet.Range("A2").PasteSpecial
   
End Sub

Hình như bài này chơi MS Query cũng được nhỉ?
 
Upvote 0
AutoReply đã viết:
Cuối tuần giải trí chút nha các bạn.
Nhờ các bạn lấy dữ liệu từ file đang đóng data.xlsx tại những dòng có stt nằm giữa 100 và 1000
Mà không sử dụng các công cụ Vòng lặp , Filter , ADO
Khuyến khích "chơi thế lạ"
Cảm ơn các bạn
Nhấp chuột vào đây để mở rộng...
Dùng Macro4 hay dùng hàm vậy bạn?
Tôi dùng hàm thử:
PHP: 
Sub LayDL()
    With Range("A100:B1000")
        .Formula = "='" & ThisWorkbook.path & "\[" & "Data.xlsx" & " ]" & "Sheet1" & "'!" & "A99:B1000"
        .Value = .Value
    End With
    Range("A2:B99").EntireRow.Delete
    
End Sub
Là do bạn không nói stt có thể không liên tục.
 
Upvote 0
AutoReply đã viết:
Cuối tuần giải trí chút nha các bạn.
Nhờ các bạn lấy dữ liệu từ file đang đóng data.xlsx tại những dòng có stt nằm giữa 100 và 1000
Mà không sử dụng các công cụ Vòng lặp , Filter , ADO
Khuyến khích "chơi thế lạ"
Cảm ơn các bạn
Nhấp chuột vào đây để mở rộng...
Dùng lại code của chị bữa hổm:
PHP: 
Sub getdata()
    spath = "='D:\[data.xlsx]Sheet1'!A100"
    [a1].Formula = spath: [a1:b1].FillRight: Range("a1:b" & 1000 - 100 + 1).FillDown
    Range("a1:b" & 1000 - 100 + 1).Value = Range("a1:b" & 1000 - 100 + 1).Value
End Sub
 
Upvote 0
xì tin đã viết:
Dùng Macro4 hay dùng hàm vậy bạn?
Tôi dùng hàm thử:
PHP: 
Sub LayDL()
    With Range("A100:B1000")
        .Formula = "='" & ThisWorkbook.path & "\[" & "Data.xlsx" & " ]" & "Sheet1" & "'!" & "A99:B1000"
        .Value = .Value
    End With
    Range("A2:B99").EntireRow.Delete
   
End Sub
Là do bạn không nói stt có thể không liên tục.
Nhấp chuột vào đây để mở rộng...

Đố vui mà bạn, cứ ra kết quả là được hết. Cám ơn bạn. :):)
 
Upvote 0
AutoReply đã viết:
Cuối tuần giải trí chút nha các bạn.
Nhờ các bạn lấy dữ liệu từ file đang đóng data.xlsx tại những dòng có stt nằm giữa 100 và 1000
Mà không sử dụng các công cụ Vòng lặp , Filter , ADO
Khuyến khích "chơi thế lạ"
Cảm ơn các bạn
Nhấp chuột vào đây để mở rộng...
Cũng nghịch ngợm tí tẹo:
PHP: 
Sub hibe()
Dim s1, s2, n: s1 = 100: s2 = 1000: n = "titeo"
With Sheet1
    .Names.Add Name:=n, RefersTo:="='" & ThisWorkbook.Path & "\[data.xlsx]Sheet1'!$A$" & s1 + 1 & ":$B$" & s2 - 1
    .Range("A2:B" & s2 - s1).FormulaArray = "=titeo"
    .Range("A2:B" & s2 - s1).Value = Range("A2:B" & s2 - s1).Value
    .Names(n).Delete
End With
End Sub

@eke_rula : Lại thêm vụ xác định "giới tính" :p:p
 
Upvote 0
dhn46 đã viết:
Hình như bài này chơi MS Query cũng được nhỉ?
Nhấp chuột vào đây để mở rộng...

Các bạn kia "chơi ăn gian" quá nhỉ, nhưng mình thích sự nhiệt tình của các bạn .
DHN à, bạn có nghiên cứu về mấy cái MS query không ? Mình mới thử nghiệm vài thí dụ về nó nhưng thấy tốc độ trả về rất chậm.
Nếu được bạn xem thử giúp mình đoạn này mình có bị thiếu ở đâu không mà tốc độ rất chậm . Cảm ơn bạn nhiều.

Mã: 
Public Sub hello()
Dim Link As String, lo As ListObject
Link = ThisWorkbook.Path & "\data.xlsx"
ThisWorkbook.Queries.Add "myquery", "let " & _
" Source = Excel.Workbook(File.Contents(""" & Link & """), null, true), " & _
" Sheet1_Sheet = Source{[Item=""Sheet1"",Kind=""Sheet""]}[Data], " & _
" Headers = Table.PromoteHeaders(Sheet1_Sheet), " & _
" filter = Table.SelectRows(Headers, each [stt] > 100 and [stt] < 1000) in filter"

Set lo = Sheet1.ListObjects.Add(xlSrcExternal, "OLEDB;Provider=Microsoft.Mashup.OleDb.1;" & _
"Data Source=$Workbook$;Location=myquery", Destination:=Sheet1.[E2])
lo.TableStyle = ""
With lo.QueryTable
    .CommandText = "SELECT * FROM [myquery]"
    .Refresh BackgroundQuery:=False
End With
lo.Unlist
ThisWorkbook.Queries("myquery").Delete
End Sub

Lưu ý đoạn code trên chỉ chạy được với Excel 2016, các phiên bản trước có thể sẽ không được vì không có

Mã: 
Microsoft.Mashup.OleDb.1
 
Upvote 0
AutoReply đã viết:
Các bạn kia "chơi ăn gian" quá nhỉ, nhưng mình thích sự nhiệt tình của các bạn .
DHN à, bạn có nghiên cứu về mấy cái MS query không ? Mình mới thử nghiệm vài thí dụ về nó nhưng thấy tốc độ trả về rất chậm.
Nếu được bạn xem thử giúp mình đoạn này mình có bị thiếu ở đâu không mà tốc độ rất chậm . Cảm ơn bạn nhiều.

Mã: 
Public Sub hello()
Dim Link As String, lo As ListObject
Link = ThisWorkbook.Path & "\data.xlsx"
ThisWorkbook.Queries.Add "myquery", "let " & _
" Source = Excel.Workbook(File.Contents(""" & Link & """), null, true), " & _
" Sheet1_Sheet = Source{[Item=""Sheet1"",Kind=""Sheet""]}[Data], " & _
" Headers = Table.PromoteHeaders(Sheet1_Sheet), " & _
" filter = Table.SelectRows(Headers, each [stt] > 100 and [stt] < 1000) in filter"

Set lo = Sheet1.ListObjects.Add(xlSrcExternal, "OLEDB;Provider=Microsoft.Mashup.OleDb.1;" & _
"Data Source=$Workbook$;Location=myquery", Destination:=Sheet1.[E2])
lo.TableStyle = ""
With lo.QueryTable
    .CommandText = "SELECT * FROM [myquery]"
    .Refresh BackgroundQuery:=False
End With
lo.Unlist
ThisWorkbook.Queries("myquery").Delete
End Sub

Lưu ý đoạn code trên chỉ chạy được với Excel 2016, các phiên bản trước có thể sẽ không được vì không có

Mã: 
Microsoft.Mashup.OleDb.1
Nhấp chuột vào đây để mở rộng...
kể cũng lạ chạy lần đầu tiên nó dùng giật quay vòng mấy cái mới ra ... lần 2 trở đi sao nó ra nhanh vậy he
Món này keo là gì vậy Bạn ...?!
 
Upvote 0
Chào bạn AutoReply mình không có nghiên cứu về Ms Query bạn ah.
 
Upvote 0
Ngồi thử QueryTable trên Excel 2010 cũng ra đáp án của bạn, thôi thì góp vui chứ hổng có hiểu gì hết +-+-+-++-+-+-++-+-+-+
Mã: 
Sub GetData()
    With ActiveSheet.ListObjects.Add(0, Source:= _
        "ODBC;DSN=Excel Files;DBQ=D:\data.xlsx;DefaultDir=D:;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
       , Destination:=Range("$A$1")).QueryTable
        .CommandText = "SELECT * FROM `D:\data.xlsx`.`Sheet1$` WHERE [stt] > 100 and [stt] < 1000"
        .Refresh
    End With
End Sub
 
Upvote 0
dhn46 đã viết:
Ngồi thử QueryTable trên Excel 2010 cũng ra đáp án của bạn, thôi thì góp vui chứ hổng có hiểu gì hết +-+-+-++-+-+-++-+-+-+
Mã: 
Sub GetData()
    With ActiveSheet.ListObjects.Add(0, Source:= _
        "ODBC;DSN=Excel Files;DBQ=D:\data.xlsx;DefaultDir=D:;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
       , Destination:=Range("$A$1")).QueryTable
        .CommandText = "SELECT * FROM `D:\data.xlsx`.`Sheet1$` WHERE [stt] > 100 and [stt] < 1000"
        .Refresh
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cái này office 2016 - Windows10 nó ra như hìnhCapture.PNG
 
Upvote 0
dhn46 đã viết:
Ngồi thử QueryTable trên Excel 2010 cũng ra đáp án của bạn, thôi thì góp vui chứ hổng có hiểu gì hết +-+-+-++-+-+-++-+-+-+
Mã: 
Sub GetData()
    With ActiveSheet.ListObjects.Add(0, Source:= _
        "ODBC;DSN=Excel Files;DBQ=D:\data.xlsx;DefaultDir=D:;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
       , Destination:=Range("$A$1")).QueryTable
        .CommandText = "SELECT * FROM `D:\data.xlsx`.`Sheet1$` WHERE [stt] > 100 and [stt] < 1000"
        .Refresh
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Có thể chỉnh lại như sau:
Mã: 
Sub GetData()
    With ActiveSheet.ListObjects.Add(0, Source:="ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.path & "\data.xlsx;", Destination:=Range("$C$1")).QueryTable
        .CommandText = "SELECT * FROM [Sheet1$] WHERE [stt] BETWEEN 100 and 1000"
        .Refresh
    End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
dhn46 đã viết:
Cái này mình không có Excel 2016 để Test, có thể cấu trúc lệnh 2010 và 2016 có khác nhau chút chút. Bạn thử Record macro xem khác điểm nào rồi post cho mình tham khảo nhé ^^.
Nhấp chuột vào đây để mở rộng...
Record macro office 2016 nó ra vầy
Mã: 
Sub Macro1()
'
' Macro1 Macro
'

'
    ActiveWorkbook.Queries.Add Name:="Sheet1", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.Workbook(File.Contents(""D:\dovui\data.xlsx""), null, true)," & Chr(13) & "" & Chr(10) & "    Sheet1_Sheet = Source{[Item=""Sheet1"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    #""Promoted Headers"" = Table.PromoteHeaders(Sheet1_Sheet)," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""stt"", Int64.Type}, {""gt"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    Sheets.Add After:=ActiveSheet
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Sheet1" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Sheet1]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = False
        .ListObject.DisplayName = "Sheet1"
        .Refresh BackgroundQuery:=False
    End With
    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    Range("H16").Select
End Sub
Còn thử Nhấn OK xem sao nó Báo lỗi .Refresh .... Mạnh bỏ luôn .Refresh ...nó không ra gì cả
 
Upvote 0
kieu manh đã viết:
Record macro office 2016 nó ra vầy
Mã: 
Sub Macro1()
'
' Macro1 Macro
'

'
    ActiveWorkbook.Queries.Add Name:="Sheet1", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.Workbook(File.Contents(""D:\dovui\data.xlsx""), null, true)," & Chr(13) & "" & Chr(10) & "    Sheet1_Sheet = Source{[Item=""Sheet1"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    #""Promoted Headers"" = Table.PromoteHeaders(Sheet1_Sheet)," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""stt"", Int64.Type}, {""gt"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    Sheets.Add After:=ActiveSheet
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Sheet1" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Sheet1]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = False
        .ListObject.DisplayName = "Sheet1"
        .Refresh BackgroundQuery:=False
    End With
    Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
    Range("H16").Select
End Sub
Còn thử Nhấn OK xem sao nó Báo lỗi .Refresh .... Mạnh bỏ luôn .Refresh ...nó không ra gì cả
Nhấp chuột vào đây để mở rộng...
Anh sửa thành SELECT * FROM [Sheet1$] xem được không?
 
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
Nhờ gở rối công thức Averageif trong sheet summary
Trả lời
5
Đọc
64
HieuCD
H
nnthoi1994
Tự động gửi tin nhắn skype thông qua VBA
    • Thích
Trả lời
16
Đọc
613
befaint
befaint
L
  • Question
Lấy nội dung chát trên skype về excel
Trả lời
8
Đọc
555
nnthoi1994
nnthoi1994
H
  • Question
xin các thầy cho em xin bảng quy ước màu trong vba
Trả lời
17
Đọc
11K
VetMini
V
hung2412
Cần giải đáp: Sau khi Auto Fit dòng thì dòng nó không tự co lại
Trả lời
1
Đọc
58
quyenpv
quyenpv
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