Đố 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

 

[Hai Lúa Miền Tây]

Tạm chấp nhận
Tăng độ khó nha anh: Không dùng vòng để kiểm tra mà chuyển đổi trực tiếp luôn
Ẹc... Ẹc...
(Đố vui mà, đương nhiên phải có điểm khác biệt)

Sửa lại chút xíu như sau được không Thầy?

Function ShName(ByVal shCodeName As String) As String
      ShName = ThisWorkbook.VBProject.vbcomponents(shCodeName).Properties("Name").Value

End Function

 

[ndu96081631]

Sửa lại chút xíu như sau được không Thầy?

Function ShName(ByVal shCodeName As String) As String
      ShName = ThisWorkbook.VBProject.vbcomponents(shCodeName).Properties("Name").Value

End Function

Chính xác!
Hổng làm khó được Hai Lúa hen
(hổng ấy chú ra đề đi! Nguyên tắc là: lời giải ngắn gọn và độc đáo)

 

[ndu96081631]

Giả sử tôi có dữ liệu (như hình dưới).
Giờ người ta muốn trích lấy 1 vài cột nào đó sang sheet khác. Chẳng hạn muốn lấy các cột có tiêu đề sau: DATE, DEPT, MATERIAL NAME, QTY., AMOUNT(VND) ---> Tiếp theo đặt dữ liệu sang sheet khác và đổi luôn vị trí cột của kết quả thành MATERIAL NAME, DATE, DEPT, QTY., AMOUNT(VND)
Xin hỏi: Viết code thế nào là ngắn gọn nhất?
(dạo này diễn đàn lạ thật ---> Hổng biết phải Edit hình như thế nào nữa)

 

[le tin]

Giả sử tôi có dữ liệu (như hình dưới).
Giờ người ta muốn trích lấy 1 vài cột nào đó sang sheet khác. Chẳng hạn muốn lấy các cột có tiêu đề sau: DATE, DEPT, MATERIAL NAME, QTY., AMOUNT(VND) ---> Tiếp theo đặt dữ liệu sang sheet khác và đổi luôn vị trí cột của kết quả thành MATERIAL NAME, DATE, DEPT, QTY., AMOUNT(VND)
Xin hỏi: Viết code thế nào là ngắn gọn nhất?
(dạo này diễn đàn lạ thật ---> Hổng biết phải Edit hình như thế nào nữa)

Mình tham gia đoạn code này :
Dim i As Long, j As Long
For i = 1 To 5
j = Choose(i, 4, 1, 2, 10, 12)
Sheet2.Columns(i).Value = Sheet1.Columns(j).Value
Next

 

[ptm0412]

Dùng mảng: 1 mảng Source 1 mảng Result:

1 dòng lệnh đếm số dòng dữ liệu
1 dòng gán giá trị vào mảng Source,
1 dòng gán mảng kết quả xuống
1 vòng lặp ít nhất 5 dòng lệnh bên trong (= 7 dòng)

Tổng cộng 10 dòng. Ẹc ẹc

 

[ndu96081631]

Mình tham gia đoạn code này :
Dim i As Long, j As Long
For i = 1 To 5
j = Choose(i, 4, 1, 2, 10, 12)
Sheet2.Columns(i).Value = Sheet1.Columns(j).Value
Next

Sao bạn biết chắc các tiêu đề ấy nằm ở vị trí 1, 2, 4, 10 và 12?
Nói chung là truy xuất theo TÊN TIÊU ĐỀ và không biết nó nằm ở cột nào
(đương nhiên đã là đố vui thì giải pháp rất ngắn gọn)

 

[Hai Lúa Miền Tây]

Giả sử tôi có dữ liệu (như hình dưới).
Giờ người ta muốn trích lấy 1 vài cột nào đó sang sheet khác. Chẳng hạn muốn lấy các cột có tiêu đề sau: DATE, DEPT, MATERIAL NAME, QTY., AMOUNT(VND) ---> Tiếp theo đặt dữ liệu sang sheet khác và đổi luôn vị trí cột của kết quả thành MATERIAL NAME, DATE, DEPT, QTY., AMOUNT(VND)
Xin hỏi: Viết code thế nào là ngắn gọn nhất?
(dạo này diễn đàn lạ thật ---> Hổng biết phải Edit hình như thế nào nữa)

Em dùng ADO thử, mặc dù đã cố gắng rút gọn, nhưng cũng còn dài thoòng.

Sub FillList()
Dim cnn As New ADODB.Connection, lrs As New ADODB.Recordset, r As Integer
cnn.Open "Provider= Microsoft.Jet.OLEDB.4.0; data source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
With Sheet2
        lrs.Open "select [MATERIAL NAME], [DATE], [DEPT], [QTY#], [AMOUNT(VND)] From [Sheet1$]", cnn, 1, 3
        For i = 0 To (lrs.Fields.Count - 1)
            .Cells(1, i + 1) = lrs.Fields(i).Name
        Next
        .Range("A2").CopyFromRecordset lrs
    
End With
lrs.Close: Set lrs = Nothing: cnn.Close: Set cnn = Nothing
End Sub

 

[ndu96081631]

Mình nói thêm về bài toán này:
1> Đầu vào:

- Ta có dữ liệu nguồn, chẳng hạn là SrcRng = Sheet1.Range("A1:L10000")
- Tên các tiêu đề cần lấy cũng được cho trước, chẳng hạn là aTitle =Array("MATERIAL NAME","DATE","DEPT","QTY.","AMOUNT(VND)")
​

2> Đầu ra: Lọc sang sheet 2 với tên tiêu đề đã cho trong biến aTitle (và đúng theo thứ tự)
----------------------

Em dùng ADO thử, mặc dù đã cố gắng rút gọn, nhưng cũng còn dài thoòng.

Đao to búa lớn quá! Đố vui mà lị ---> Nó đâu có phức tạp đến vậy
Ẹc... Ẹc...

 

[le tin]

Mình chỉnh lại đọan này :
Dim i As Long, k As String, j As Long
For i = 1 To 5
k = Choose(i, "MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
j = WorksheetFunction.Match(k, Sheet1.[A1:Z1], 0)
Sheet2.Columns(i).Value = Sheet1.Columns(j).Value
Next

 

[ndu96081631]

Mình chỉnh lại đọan này :
Dim i As Long, k As String, j As Long
For i = 1 To 5
k = Choose(i, "MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
j = WorksheetFunction.Match(k, Sheet1.[A1:Z1], 0)
Sheet2.Columns(i).Value = Sheet1.Columns(j).Value
Next

Aí chà chà!
Tạm được đi nhưng... KHÔNG VUI TÍ NÀO
Ẹc... Ẹc... nghĩ cách khác xem
(một giải pháp nói ra thì thấy dễ nhưng chưa nói thì... ít khi nghĩ đến)

 

[sealand]

Mình tham gia thế này:

Sub Test()
Dim i, aTitle(), Rg As Range
aTitle = Array("MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
For i = 0 To UBound(aTitle)
If Rg Is Nothing Then Set Rg = Sheet1.UsedRange.Find(aTitle(i)).Resize(Sheet1.UsedRange.Rows.Count) _
Else Set Rg = Application.Union(Rg, Sheet1.UsedRange.Find(aTitle(i)).Resize(Sheet1.UsedRange.Rows.Count))
Next
Rg.Copy Sheet2.[A1]
End Sub

 

[Hai Lúa Miền Tây]

Hình như thứ tự cột chưa theo yêu cầu đề bài anh à.

 

[ndu96081631]

Bài toán trích lọc 1 vài cột trong toàn bộ dữ liệu chắc chắn có ứng dụng rất nhiều trong thực tế. Vậy không biết nếu phải làm bằng tay thì mọi người sẽ làm thế nào nhỉ?
(copy từng cột paste sang ta khỏi cần bàn đến đi)
Nghiaphuc biết chiêu này

 

[hoangvuluan]

Bài toán trích lọc 1 vài cột trong toàn bộ dữ liệu chắc chắn có ứng dụng rất nhiều trong thực tế. Vậy không biết nếu phải làm bằng tay thì mọi người sẽ làm thế nào nhỉ?
(copy từng cột paste sang ta khỏi cần bàn đến đi)
Nghiaphuc biết chiêu này

Thường thì sẽ làm theo quy trình sau:
1. (double sheet) copy sang 1 sheet mới bằng cách Ctrl-Drag
2. (delete) Chọn các cột không để xóa 1 lần, hoặc xóa 1 cột sao đó chọn và nhấn F4 lặp lại lệnh...
3. (sort) Shift+Drag cột đến vị trí mong muốn

 

[ThuNghi]

Bài toán trích lọc 1 vài cột trong toàn bộ dữ liệu chắc chắn có ứng dụng rất nhiều trong thực tế. Vậy không biết nếu phải làm bằng tay thì mọi người sẽ làm thế nào nhỉ?
(copy từng cột paste sang ta khỏi cần bàn đến đi)
Nghiaphuc biết chiêu này

Có ai dùng "rừng" thế này?
Hay phải mảng trong mảng.

Sub Macro1()
Dim i&, sTxt$
aTitle = Array("MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
sTxt = Join(aTitle, vbBack)
Sheet1.Range("A1:L18").Copy Sheet2.Range("A1")
Sheet2.Select
Range("A1:L18").Value = Range("A1:L18").Value
For i = 12 To 1 Step -1
  If InStr(sTxt, Cells(1, i)) = 0 Then
    Columns(i).Delete Shift:=xlToLeft
  End If
Next i
End Sub

 

[nghiaphuc]

Bài toán trích lọc 1 vài cột trong toàn bộ dữ liệu chắc chắn có ứng dụng rất nhiều trong thực tế. Vậy không biết nếu phải làm bằng tay thì mọi người sẽ làm thế nào nhỉ?
(copy từng cột paste sang ta khỏi cần bàn đến đi)
Nghiaphuc biết chiêu này

Đọc cái chỗ anh ndu ẩn đi kia mới nhớ. Khà khà... Em biết rồi. Hóa ra đây là chiêu anh ndu còn biết sau em. Ẹc ẹc...

 

[le tin]

Có ai dùng "rừng" thế này?
Hay phải mảng trong mảng.

Sub Macro1()
Dim i&, sTxt$
aTitle = Array("MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
sTxt = Join(aTitle, vbBack)
Sheet1.Range("A1:L18").Copy Sheet2.Range("A1")
Sheet2.Select
Range("A1:L18").Value = Range("A1:L18").Value
For i = 12 To 1 Step -1
  If InStr(sTxt, Cells(1, i)) = 0 Then
    Columns(i).Delete Shift:=xlToLeft
  End If
Next i
End Sub

Hình như chưa đúng thứ tự

 

[ndu96081631]

Đọc cái chỗ anh ndu ẩn đi kia mới nhớ. Khà khà... Em biết rồi. Hóa ra đây là chiêu anh ndu còn biết sau em. Ẹc ẹc...

Thì học của chú mà...
Tuy cũng hổng phải cái gì ghê gớm nhưng ít ai biết (dù xài hoài) thì cũng xem như tuyệt chiêu rồi
Ẹc... Ẹc...

 

[thanhlanh]

Thì học của chú mà...
Tuy cũng hổng phải cái gì ghê gớm nhưng ít ai biết (dù xài hoài) thì cũng xem như tuyệt chiêu rồi
Ẹc... Ẹc...

Vậy được không:

Sub doVui()
    Dim aTitle, SrcRng
    aTitle = Array("MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
    Range("A1").Resize(, UBound(aTitle) + 1) = aTitle
    Set SrcRng = Sheet1.Range("A1:L10000")
    Worksheets(2).Range("A2").Resize(SrcRng.Rows.Count, UBound(aTitle) + 1) = "=HLOOKUP(Sheet2!R1C,Sheet1!R1C1:R1000C12,ROW(),0)"
    Worksheets(2).Range("A2").Resize(SrcRng.Rows.Count, UBound(aTitle) + 1) = Range("A2").Resize(SrcRng.Rows.Count, UBound(aTitle) + 1).Value
End Sub

 

[Hoàng Trọng Nghĩa]

Em lại làm như vầy:

Sub ChuyenCot()
    Dim sArray As Variant, tittleArr As Variant, TransSheet As Variant
    Dim c As Long, h As Long, i As Long, j As Long, k As Long, r As Long, t As Long
    
    sArray = Sheet1.Range("A1:L18").Value
    tittleArr = Array("MATERIAL NAME", "DATE", "DEPT", "QTY.", "AMOUNT(VND)")
    
    t = UBound(tittleArr): c = 0
    h = UBound(sArray, 1): j = UBound(sArray, 2)
    
    ReDim TransSheet(1 To h, 1 To t + 1)
    For k = 0 To t
        For i = 1 To j
            If sArray(1, i) = tittleArr(k) Then
                c = c + 1
                For r = 1 To h
                    TransSheet(r, c) = sArray(r, i)
                Next
            End If
        Next
    Next
    Sheet2.Cells.Clear
    Sheet2.Range("A1").Resize(h, c).Value = TransSheet
End Sub