Đố vui về VBA!

[anhtuan1066]

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:

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

 

[siwtom]

Vui quá, cũng tham gia

[GPECODE=vb]
Dim Arr
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
Range("A1").Resize(UBound(Arr) + 1, 1).FormulaArray = "={""" & Join(Arr, """;""") & """}"
[/GPECODE]
---------------
Nếu cần dùng cho cả về sau thì ta thêm luôn Name

[GPECODE=vb]
Dim Arr, s
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
s = "={""" & Join(Arr, """;""") & """}"
ThisWorkbook.Names.Add Name:="myArr", RefersTo:=s
Range("A1").Resize(UBound(Arr) + 1, 1).FormulaArray = "=myArr"
[/GPECODE]

 

[ndu96081631]

Vui quá, cũng tham gia

[GPECODE=vb]
Dim Arr
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
Range("A1").Resize(UBound(Arr) + 1, 1).FormulaArray = "={""" & Join(Arr, """;""") & """}"
[/GPECODE]
---------------
Nếu cần dùng cho cả về sau thì ta thêm luôn Name

[GPECODE=vb]
Dim Arr, s
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
s = "={""" & Join(Arr, """;""") & """}"
ThisWorkbook.Names.Add Name:="myArr", RefersTo:=s
Range("A1").Resize(UBound(Arr) + 1, 1).FormulaArray = "=myArr"
[/GPECODE]

----------------------

Em cũng tham gia 1 cách: Không vòng lặp, không Transpose

Sub Test()
    Dim Str As String
    Dim Arr
    Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban")
    Str = """" & VBA.Join(Arr, """;""") & """"
    Range("A1").Resize(UBound(Arr), 1).FormulaArray = "=INDEX({" & Str & "},ROW())"
End Sub

Chấp nhận các giải pháp
Tuy nhiên, các bạn khác vẫn còn cơ hội
Ẹc... Ẹc...

 

[siwtom]

----------------------

Chấp nhận các giải pháp
Tuy nhiên, các bạn khác vẫn còn cơ hội
Ẹc... Ẹc...

Thử chơi cách "quái đản"

[GPECODE=vb]
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As Long)

Sub Test()
Dim Arr, Arr2, bArr() As Byte
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
ReDim Arr2(LBound(Arr) To UBound(Arr), 1 To 1)

CopyMemory Arr2(LBound(Arr2), 1), Arr(LBound(Arr)), (UBound(Arr) + 1) * 16
Range("A1").Resize(UBound(Arr) + 1, 1).Value = Arr2

ReDim bArr(1 To (UBound(Arr) + 1) * 16)
CopyMemory Arr2(LBound(Arr2), 1), bArr(1), (UBound(Arr) + 1) * 16
End Sub
[/GPECODE]

---------------------

Cất "nhờ" vào bộ nhớ đệm

[GPECODE=vb]
Dim Arr
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Join(Arr, vbCrLf)
.PutInClipboard
End With
Range("A1").PasteSpecial xlPasteAll
[/GPECODE]

 

[Good-Luck]

----------------------

Chấp nhận các giải pháp
Tuy nhiên, các bạn khác vẫn còn cơ hội
Ẹc... Ẹc...

sản phảm của bác Siwtom
[GPECODE=vb]Sub test()Dim Narr(), chuoi As String
Narr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban")
chuoi = Join(Narr(), """;""")
[a1:a6].FormulaArray = "= {""" & chuoi & """}"
End Sub


[/GPECODE]

 

[ndu96081631]

Cất "nhờ" vào bộ nhớ đệm

[GPECODE=vb]
Dim Arr
Arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban", "quy lam", "ban oi")
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Join(Arr, vbCrLf)
.PutInClipboard
End With
Range("A1").PasteSpecial xlPasteAll
[/GPECODE]

Chính xác là em muốn nói đến cái này đây. Em nghĩ tốc độ có thể nhanh hơn phương pháp dùng công thức
-------------
Đây là đáp án của em:

Sub Arr1DToColumn(ByVal arr1D, ByVal Target As Range)
  Dim text As String
  On Error GoTo ExitSub
  text = Join(arr1D, vbLf)
  With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .Clear
    .SetText text
    .PutInClipboard
  End With
  Target.PasteSpecial
ExitSub:
End Sub

Sub Main()
  Dim arr
  arr = Array("Giai", "phap", "Excel", "cong cu", "tuyet voi", "cua ban")
  Arr1DToColumn arr, Sheet1.Range("A1")
End Sub

Giải thuật:
- Nối mảng lại bẳng ký tự ngắt dòng (vbLf)
- Cho chuổi vừa nối vào Clipboard
- Giờ trên bảng tính, chỉ việc chọn 1 cell bất kỳ rồi Ctrl + V sẽ có kết quả
Ẹc... Ẹc...
------------------
Áp dụng mở rộng:
Với 1 file txt được lưu từ file Excel (dòng cách dòng bằng ký tự vbCrLf và cột cách cột bằng ký tự vbTab), ta có thể áp dụng cách này để đưa dữ liệu từ txt vào Excel 1 cách dễ dàng. Cách làm như sau:
- Đọc file text
- Cho vào Clipboard
- Ctrl + V để paste vào Excel

 

[levanduyet]

Chiêu này từ nào giờ em chưa rờ đến.
Nếu cất nhờ vào bộ nhớ liệu nó có giới hạn nào không anh?

Ngoài ra góp ý anh, là mai mốt cho đề bài kỹ hơn

Lê Văn Duyệt

 

[ndu96081631]

Chiêu này từ nào giờ em chưa rờ đến.
Nếu cất nhờ vào bộ nhớ liệu nó có giới hạn nào không anh?

Ai biết đâu nè! Khi nào có dịp xài đến mình sẽ thí nghiệm

Ngoài ra góp ý anh, là mai mốt cho đề bài kỹ hơn
Lê Văn Duyệt

Xin lỗi! Tại không lường hết các tình huống ấy mà
Ẹc... Ẹc...

 

[thanhlanh]

Đương nhiên! Nếu không thì còn gọi gì là ĐỐ VUI
Ở đây, vụ trùng ta khỏi cần bàn tới đi, vì dù sao thì cũng có Dictionary đảm nhận việc này... Mình chỉ bàn về giải thuật tạo 1 chuổi với 5 ký tự ngẫu nhiên thôi
(nếu nói ra, chắc chắn ai cũng nói rằng "ĐÃ TỪNG BIẾT", có điều trong 1 thoáng chưa kịp nghĩ đến)
-----------------
Nói thêm: Nếu tôi làm bài này thì sẽ không có bất cứ dòng nào liên quan đến hàm RAND

Hình như bài này vẫn chưa có đáp án của tác giả, mọi người làm cho vui cửa vui nhà, còn không, tác giả giải luôn cho mọi người chiêm ngưỡng.

 

[ndu96081631]

Hình như bài này vẫn chưa có đáp án của tác giả, mọi người làm cho vui cửa vui nhà, còn không, tác giả giải luôn cho mọi người chiêm ngưỡng.

Trời ơi! Chẳng thấy ai hỏi, xém quên
Anh vào cửa sổ Immediate, gõ dòng lệnh này xem:

[B]?Mid(CreateObject("Scripting.FileSystemObject").GetTempName, 4, 5) [/B]

 

[thanhlanh]

Trời ơi! Chẳng thấy ai hỏi, xém quên
Anh vào cửa sổ Immediate, gõ dòng lệnh này xem:

[B]?Mid(CreateObject("Scripting.FileSystemObject").GetTempName, 4, 5) [/B]

Hi, buộc phải có vòng lặp hả bạn?
Mình thử với code này:

Sub abc()    
Application.ScreenUpdating = False
    Dim i As long
    On Error Resume Next
    Do Until Err > 0
        i = i + 1
        Range("A" & i) = CreateObject("Scripting.FileSystemObject").GetTempName
    Loop
    Application.ScreenUpdating = True
    MsgBox i
End Sub

Chạy trên Excel2010 miệt mài luôn, nếu không giới hạn i, lọc duy nhất thấy cũng có trùng. Cũng hay!

 

[ndu96081631]

Hi, buộc phải có vòng lặp hả bạn?
Mình thử với code này:

Sub abc()    
Application.ScreenUpdating = False
    Dim i As long
    On Error Resume Next
    Do Until Err > 0
        i = i + 1
        Range("A" & i) = CreateObject("Scripting.FileSystemObject").GetTempName
    Loop
    Application.ScreenUpdating = True
    MsgBox i
End Sub

Cũng hay!

Cái này chuyên dùng để tạo 1 file tạm (có tên ngẫu nhiên) trên đĩa cứng. Giờ ta "chế" lại thôi
Có điều chạy 1 số lần nhất định nào đó thì sẽ có trùng. Vậy nên anh phải kết hợp với Dictionary nữa thì mới hoàn chỉnh

 

[thanhlanh]

Khuấy động một tí cho vui!

Làm sao để tạo được một mảng như thế này:

For i = 1 To 10
    ' .....................
    Arr(i).Value = Cells(i, 1)
    Arr(i).Name = Cells(i, 2)
Next i

và sử dụng:

MsgBox UBound(Arr)
MsgBox Arr(8).Name

 

[ndu96081631]

Khuấy động một tí cho vui!

Làm sao để tạo được một mảng như thế này:

For i = 1 To 10
    ' .....................
    Arr(i).Value = Cells(i, 1)
    Arr(i).Name = Cells(i, 2)
Next i

và sử dụng:

MsgBox UBound(Arr)
MsgBox Arr(8).Name

Mình đã từng xài cái chiêu tương tự thế này rồi... Có điều chưa biết cái mà mình xài có giống như ý của anh không?
(chắc là giống)
Ẹc... Ẹc....

 

[Hoàng Trọng Nghĩa]

Khuấy động một tí cho vui!

Làm sao để tạo được một mảng như thế này:

For i = 1 To 10
    ' .....................
    Arr(i).Value = Cells(i, 1)
    Arr(i).Name = Cells(i, 2)
Next i

và sử dụng:

MsgBox UBound(Arr)
MsgBox Arr(8).Name

Kiểu này em thường xuyên làm với UserForm, đặt một biến mảng 1 chiều với các phần tử là các TextBox hay ComboBox, ...

Nói như thế chắc anh ThanhLanh biết em biết cách thực hiện rồi chứ?

 

[thanhlanh]

Kiểu này em thường xuyên làm với UserForm, đặt một biến mảng 1 chiều với các phần tử là các TextBox hay ComboBox, ...

Nói như thế chắc anh ThanhLanh biết em biết cách thực hiện rồi chứ?

Đó cũng là một hướng nhưng mình không phải dùng cách đó.
Vậy nói thêm: Không được dùng TextBox, ComboBox, ListBox, ..., các đối tượng tương tự trên Form

 

[Hoàng Trọng Nghĩa]

Đó cũng là một hướng nhưng mình không phải dùng cách đó.
Vậy nói thêm: Không được dùng TextBox, ComboBox, ListBox, ..., các đối tượng tương tự trên Form

Vậy chỉ có làm các Define Name tự động thôi à!

(Mà nếu như vậy thì làm trực tiếp trên Range chứ sao phải qua công đoạn Array chi cho phức tạp vậy ta?)

 

[ndu96081631]

Vậy chỉ có làm các Define Name tự động thôi à!

Để ý cái Arr(i).Value và Arr(i).Name thì biết các phần tử của Arr phải là BIẾN ĐỐI TƯỢNG (và điều đương nhiên là phải có động tác SET.. gì gì đó)
Vậy hãy nghĩ đến đối tượng nào có 2 thuộc tính màu đỏ ở trên là được rồi

Mà nếu như vậy thì làm trực tiếp trên Range chứ sao phải qua công đoạn Array chi cho phức tạp vậy ta?)

Thứ nhất: Đố vui
Thứ hai: Không phải là không có ứng dụng (tôi xài vụ này hoài)

 

[siwtom]

các phần tử của Arr phải là BIẾN ĐỐI TƯỢNG

chưa hẳn thế

Khuấy động một tí cho vui!

Làm sao để tạo được một mảng như thế này:

For i = 1 To 10
    ' .....................
    Arr(i).Value = Cells(i, 1)
    Arr(i).Name = Cells(i, 2)
Next i

và sử dụng:

MsgBox UBound(Arr)
MsgBox Arr(8).Name

Ngồi một lúc là nghĩ ra cả đống thôi.

Toàn bộ code của class module clsTest

Public Value
Public Name

module1

Public Type MYSTRUCT
    Value As String
    Name As String
End Type

Sub hichic()
Dim Arr(1 To 10) As New clsTest, tmp(1 To 10) As MYSTRUCT
    For i = 1 To 10
        Arr(i).Value = Cells(i, 1)
        Arr(i).Name = Cells(i, 2)
        
        tmp(i).Value = Cells(i, 1)
        tmp(i).Name = Cells(i, 2)
    Next i
    
    MsgBox UBound(Arr)
    MsgBox Arr(8).Name
    
    MsgBox UBound(tmp)
    MsgBox tmp(8).Value
End Sub

 

[Hoàng Trọng Nghĩa]

Để ý cái Arr(i).Value và Arr(i).Name thì biết các phần tử của Arr phải là BIẾN ĐỐI TƯỢNG (và điều đương nhiên là phải có động tác SET.. gì gì đó)
Vậy hãy nghĩ đến đối tượng nào có 2 thuộc tính màu đỏ ở trên là được rồi

Thứ nhất: Đố vui
Thứ hai: Không phải là không có ứng dụng (tôi xài vụ này hoài)

Hỏng biết có ứng dụng gì, nhưng nó đại loại là như vầy nè Thầy ơi:

Sub test()
Dim Arr(1 To 3) As Object
Dim Rng As Range, i As Byte
For i = 1 To 3
    Set Rng = Cells(i, 1)
    Set Arr(i) = Rng
    Arr(i).Value = Cells(i, 2).Value
    Arr(i).Name = Cells(i, 3).Value
Next
End Sub

 

[ndu96081631]

chưa hẳn thế



Ngồi một lúc là nghĩ ra cả đống thôi.

Toàn bộ code của class module clsTest

Public Value
Public Name

module1

Public Type MYSTRUCT
    Value As String
    Name As String
End Type

Sub hichic()
Dim Arr(1 To 10) As New clsTest, tmp(1 To 10) As MYSTRUCT
    For i = 1 To 10
        Arr(i).Value = Cells(i, 1)
        Arr(i).Name = Cells(i, 2)
        
        tmp(i).Value = Cells(i, 1)
        tmp(i).Name = Cells(i, 2)
    Next i
    
    MsgBox UBound(Arr)
    MsgBox Arr(8).Name
    
    MsgBox UBound(tmp)
    MsgBox tmp(8).Value
End Sub

Em dám cá với anh rằng anh thanhlanh hổng phải nói đến cái này
-------------------------

Hỏng biết có ứng dụng gì, nhưng nó đại loại là như vầy nè Thầy ơi:

Sub test()
Dim Arr(1 To 3) As Object
Dim Rng As Range, i As Byte
For i = 1 To 3
    Set [B]Rng [/B]= Cells(i, 1)
    Set Arr(i) = Rng
    Arr(i).Value = Cells(i, 2).Value
    Arr(i).Name = Cells(i, 3).Value
Next
End Sub

Vậy thì thêm biến Rng để làm giống gì?