Đố vui về VBA!

anhtuan1066 · 30/12/07

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

AutoReply · 1/7/17

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

dhn46 · 1/7/17

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

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ỉ?

xì tin · 1/7/17

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

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.

eke_rula · 1/7/17

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

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

AutoReply · 1/7/17

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.

Đố vui mà bạn, cứ ra kết quả là được hết. Cám ơn bạn.

NguyenNgocThuHien · 1/7/17

AutoReply đã viết:
Đố vui mà bạn, cứ ra kết quả là được hết. Cám ơn bạn.

Dùng lênh goto để tạo vòng lặp ảo thì có tính không?

befaint · 1/7/17

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

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"

AutoReply · 1/7/17

dhn46 đã viết:
Hình như bài này chơi MS Query cũng được nhỉ?

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

AutoReply · 1/7/17

NguyenNgocThuHien đã viết:
Dùng lênh goto để tạo vòng lặp ảo thì có tính không?

có đáp án vui cứ việc gửi lên nhé bạn. Cảm ơn bạn.

Kiều Mạnh · 1/7/17

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

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

dhn46 · 1/7/17

Chào bạn AutoReply mình không có nghiên cứu về Ms Query bạn ah.

AutoReply · 1/7/17

kieu manh đã viết:
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 ...?!

Món này keo là "bo bo xiên que" dành cho dân quậy đó bạn. +-+-+-+

dhn46 · 1/7/17

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

Kiều Mạnh · 1/7/17

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

Cái này office 2016 - Windows10 nó ra như hình

dhn46 · 1/7/17

kieu manh đã viết:
Cái này office 2016 - Windows10 nó ra như hìnhView attachment 178724

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

Hai Lúa Miền Tây · 1/7/17

kieu manh đã viết:
Cái này office 2016 - Windows10 nó ra như hìnhView attachment 178724

Nhấn ok thì ra kết quả thôi

Hai Lúa Miền Tây · 1/7/17

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

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

Kiều Mạnh · 1/7/17

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

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ả

eke_rula · 1/7/17

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ả

Anh sửa thành SELECT * FROM [Sheet1$] xem được không?

huuthang_bd · 5/7/17

Tôi có một câu đố nho nhỏ. Đúng nghĩa đó vui luôn

Viết code copy giá trị và định dạng từ A1:A10 sang C1:C10 sao cho code gọn nhất.

Đố vui về VBA!

Thành viên gạo cội

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

File đính kèm

Hướng tới tương lai

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

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

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

Cute Black Cat

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

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

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

I don't program, I beat code into submission!!!

Hướng tới tương lai

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

Hướng tới tương lai

I don't program, I beat code into submission!!!

Hướng tới tương lai

❆❆❆❆❆❆❆❆

❆❆❆❆❆❆❆❆

I don't program, I beat code into submission!!!

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

Chuyên gia GPE