Bài tập VBA - Macro

phihndhsp · 21/3/15

HYen17 đã viết:
Tôi có 4 cột số liệu (như trong hình)
Các bạn chép giúp tôi lần lượt từng cột số liệu sang cột [G:G]

Rảnh rỗi không có gì làm nên tranh thủ làm bài này chơi

Mã:

Sub ARR_GPE()
Dim rng As Range
Dim arr
Dim I As Long, J As Long
Dim dem As Long
Dim sodong As Long
sodong = Sheet1.Range("A65000").End(xlUp).Row
Set rng = Sheet1.Range("B2:E" & sodong)
ReDim arr(1 To sodong * 4, 1 To 1)
      dem = 1
      For J = 1 To 4
          For I = 1 To sodong - 1
             arr(dem, 1) = rng(I, J)
             dem = dem + 1
        Next I
     Next J
    Sheet1.Range("G2").Resize(dem, 1) = arr
End Sub

chuot0106 · 21/3/15

Mong chủ thớt nhận xét đánh giá ưu nhược điểm của mỗi bài để rút kinh nghiệm.

SA_DQ · 21/3/15

Mong chủ thớt nhận xét đánh giá ưu nhược điểm của mỗi bài để rút kinh nghiệm.

(1) Tạm thời có 1 vài í thế này nha:
1 cách là Copy-Past; 1 cách là xài mảng; Chuyện này khi tăng số dòng có dữ liệu lên hàng vạn thì ta có thể đo thời gian của chương trình cần để vận hành macro.
Chuyện như vậy thiết tưởng mỗi bạn có thể tự xử đi!

(2) Đây cũng là 1 cách để cùng tham khảo:

PHP:

Sub MultipleColumnsIntoColumn()
 Dim Rws As Long, J As Long, W As Long
 Dim Cls As Range, Tmp()
 
 Rws = [B2].CurrentRegion.Rows.Count - 1
 ReDim Arr(1 To 5 * Rws, 1 To 1)
 
 For Each Cls In Range([B2], [B2].End(xlToRight))
    Tmp = Cls.Resize(Rws).Value
    For J = 1 To UBound(Tmp())
        W = W + 1
        Arr(W, 1) = Tmp(J, 1)
    Next J
 Next Cls
 If W Then [G2].Resize(W).Value = Arr()
End Sub

phihndhsp · 29/4/15

Lâu rồi không thấy ai tham gia vào chủ đề này nữa? nên khấy động lại cho các bạn mới tham gia
Bài tập kiểm tra xem trong vùng từ A1:H8 có phần tử yên ngựa hay không? nếu có thì có bao nhiêu phần tử như vậy?
phần tử được gọi là phần tử yên ngựa khi nó lớn nhất trong hàng và nhỏ nhất trong cột.
Nếu được thì giải bằng cách sử dụng các vòng lập để ôn lại kiến thức về VBA

SA_DQ · 29/4/15

Đường hướng giải bài này nên là vầy:

(*) Tạo vòng lặp duyệt theo từng hàng
(*) Ở mỗi hàng tìm giá trị cực đại của hàng đó & ta cho vô biến đã khai báo
(*) Áp dụng fương thức FIND() để tìm ra chỉ số cột của ô chứa trị cực đại trong hàng đang duyệt
(*) Nếu trị cực đại này bằng với trị cực tiểu trong cột là ta đã tìm thấy thì ghi ra giấy!

chuot0106 · 30/4/15

phihndhsp đã viết:
Lâu rồi không thấy ai tham gia vào chủ đề này nữa? nên khấy động lại cho các bạn mới tham gia
Bài tập kiểm tra xem trong vùng từ A1:H8 có phần tử yên ngựa hay không? nếu có thì có bao nhiêu phần tử như vậy?
phần tử được gọi là phần tử yên ngựa khi nó lớn nhất trong hàng và nhỏ nhất trong cột.
Nếu được thì giải bằng cách sử dụng các vòng lập để ôn lại kiến thức về VBA

Gửi đáp án! Code này test với dữ liệu bạn đưa thì không có phần tử nào. Trong File đính kèm của tôi thò có 2 phần tử.
Mong được nhận xét góp ý!

Mã:

Option Explicit

Public Sub yen_ngua1()
Dim i As Long, j As Long, k As Long, vtd As Integer, Arr(), dem As Long
Dim MaxR As Long, MinC As Long, vtc

    Arr = Sheet1.Range("A1").CurrentRegion
For i = 1 To UBound(Arr, 1)
MaxR = Arr(i, 1)
    For j = 1 To UBound(Arr, 2)
        If MaxR < Arr(i, j) Then
            MaxR = Arr(i, j)
            vtc = j
        Else
            MaxR = MaxR
        End If
    Next j
    MinC = Arr(1, vtc)
   For k = 1 To UBound(Arr, 1)
        If MinC > Arr(k, vtc) Then
            MinC = Arr(k, vtc)
         Else
            MinC = MinC
        End If
   Next k
        If MaxR = MinC Then dem = dem + 1
Next i
        MsgBox "Co " & dem & " phan tu yen ngua."
End Sub

phihndhsp · 30/4/15

thử bài này với kỹ thuật lập trình xem sao

Mã:

Function XetCotDong(arr, dong As Integer, cot As Integer, i As Integer, j As Integer) As Byte
 Dim K As Integer
            For K = 1 To dong
                    If (arr(K, j) < arr(i, j)) Then
                        XetCotDong = 0
                        Exit Function
                     End If
            Next
            For K = 1 To cot
                    If (arr(i, K) > arr(i, j)) Then
                        XetCotDong = 0
                         Exit Function
                     End If
           Next
            XetCotDong = 1    
  End Function

Mã:

Function DemYenNgua(arr, dong As Integer, cot As Integer) As Byte
    Dim dem As Integer
    Dim i As Integer
    Dim j As Integer
    dem = 0
    For i = 1 To dong
        For j = 1 To cot
           If (XetCotDong(arr, dong, cot, i, j) = 1) Then
            dem = dem + 1
           End If
        Next
     Next
 DemYenNgua = dem
 End Function

Mã:

Sub GPE()
Dim arr()
     arr = [COLOR=#ff0000][B]Range("A1:H8").Value[/B][/COLOR]
     MsgBox DemYenNgua(arr,[B] [COLOR=#ff0000]8[/COLOR][/B], [COLOR=#ff0000][B]8[/B][/COLOR])
End Sub

chỗ màu đỏ đó có thể thay thế

chuot0106 · 30/4/15

phihndhsp đã viết:

thử bài này với kỹ thuật lập trình xem sao

Mã:

Function XetCotDong(arr, dong As Integer, cot As Integer, i As Integer, j As Integer) As Byte
 Dim K As Integer
            For K = 1 To dong
                    If (arr(K, j) < arr(i, j)) Then
                        XetCotDong = 0
                        Exit Function
                     End If
            Next
            For K = 1 To cot
                    If (arr(i, K) > arr(i, j)) Then
                        XetCotDong = 0
                         Exit Function
                     End If
           Next
            XetCotDong = 1    
  End Function

Mã:

Function DemYenNgua(arr, dong As Integer, cot As Integer) As Byte
    Dim dem As Integer
    Dim i As Integer
    Dim j As Integer
    dem = 0
    For i = 1 To dong
        For j = 1 To cot
           If (XetCotDong(arr, dong, cot, i, j) = 1) Then
            dem = dem + 1
           End If
        Next
     Next
 DemYenNgua = dem
 End Function

Mã:

Sub GPE()
Dim arr()
     arr = [COLOR=#ff0000][B]Range("A1:H8").Value[/B][/COLOR]
     MsgBox DemYenNgua(arr,[B] [COLOR=#ff0000]8[/COLOR][/B], [COLOR=#ff0000][B]8[/B][/COLOR])
End Sub

chỗ màu đỏ đó có thể thay thế

Làm gì mà tác giả đưa đáp án sớm vậy. Theo tôi bài tập này để luyện kĩ năng dùng vòng lặp for rất hay.
P/s: bài này có nhiều cách làm, các thành viên mới học vba nên thử xem sao?

phihndhsp · 30/4/15

Bài tập đến số lượng số nguyên tố:
đếm xem trong vùng A1:H8 có bao nhiêu số nguyên tố, và tìm xem số nguyên tố nào là số nguyên tố lớn nhất

ChanhTQ@ · 30/4/15

Gửi đáp án! Code này test với dữ liệu bạn đưa thì không có phần tử nào. Trong File đính kèm của tôi thò có 2 phần tử.
Mong được nhận xét góp ý!

Ở những trường hợp đặc biệt thì bạn cần sửa lại macro rồi!
(1) Như hình
(2) Nếu trong file của bạn, ta sửa lại tại [H4] có trị là 9 thì đâu là đáp án đây?

chuot0106 · 30/4/15

phihndhsp đã viết:
Bài tập đến số lượng số nguyên tố:
đếm xem trong vùng A1:H8 có bao nhiêu số nguyên tố, và tìm xem số nguyên tố nào là số nguyên tố lớn nhất

Thử code này xem sao!

Mã:

Public Sub SNT()
Dim i As Long, j As Long, k As Long, dem_uoc As Byte, dem_s As Byte
Dim Rng As Range
Set Rng = Sheet1.Range("A1:H8")
For i = 1 To Rng.Rows.Count
    For j = 1 To Rng.Columns.Count
        dem_uoc = 0
        For k = 1 To Val(Rng(i, j))
            If Val(Rng(i, j)) Mod k = 0 Then dem_uoc = dem_uoc + 1
        Next k
        If dem_uoc = 2 Then dem_s = dem_s + 1
    Next j
Next i
    MsgBox dem_s
End Sub

Quang_Hải · 30/4/15

chuot0106 đã viết:

Thử code này xem sao!

Mã:

Public Sub SNT()
Dim i As Long, j As Long, k As Long, dem_uoc As Byte, dem_s As Byte
Dim Rng As Range
Set Rng = Sheet1.Range("A1:H8")
For i = 1 To Rng.Rows.Count
    For j = 1 To Rng.Columns.Count
        dem_uoc = 0
        For k = 1 To Val(Rng(i, j))
            If Val(Rng(i, j)) Mod k = 0 Then dem_uoc = dem_uoc + 1
        Next k
        If dem_uoc = 2 Then dem_s = dem_s + 1
    Next j
Next i
    MsgBox dem_s
End Sub

Bài này hình như chỉ cần 1 vòng For Each và 1 If để đếm số nguyên tố. Nếu lấy SNT lớn nhất thì thêm 1 If nữa là được. Lấy phần tử trong mảng chia cho 6 là có thể kiểm tra xem có phải là SNT hay không.
Cũng có thể mình sai vì chưa code ra cụ thể mà chỉ suy luận thôi.

chuot0106 · 30/4/15

Quên chưa tìm số nguyên tố lớn nhất:

Mã:

Public Sub SNT2()
Dim i As Long, j As Long, k As Long, dem_uoc As Byte, dem_s As Byte, tmp(1 To 1000), snt_max As Long, m As Integer
Dim Rng As Range
Set Rng = Sheet1.Range("A1:H8")

For i = 1 To Rng.Rows.Count
    For j = 1 To Rng.Columns.Count
        dem_uoc = 0
        For k = 2 To Val(Rng(i, j))
            If Val(Rng(i, j)) Mod k = 0 Then dem_uoc = dem_uoc + 1
        Next k
        If dem_uoc = 1 Then
            dem_s = dem_s + 1
            tmp(dem_s) = Rng(i, j)
        End If
    Next j
Next i
    For m = 1 To UBound(tmp)
        If snt_max < tmp(m) Then snt_max = tmp(m)
        Next m
            MsgBox "Co " & dem_s & " so nguyen to." & Chr(13) & "So nguyen to lon nhat la: " & snt_max
End Sub

chuot0106 · 30/4/15

Rút ngắn code đi chút:

Mã:

Option Explicit

Public Sub SNT3()
Dim i As Long, dem_uoc As Byte, dem_s As Byte, tmp, snt_max As Long
Dim Rng As Range, cll As Range
Set Rng = Sheet1.Range("A1:H8")

For Each cll In Rng
    dem_uoc = 0
    For i = 1 To cll
        If cll Mod i = 0 Then dem_uoc = dem_uoc + 1
    Next i
        If dem_uoc = 2 Then
            dem_s = dem_s + 1
            If tmp < cll Then tmp = cll
        End If
Next cll
            MsgBox "Co " & dem_s & " so nguyen to." & Chr(13) & "So nguyen to lon nhat la: " & tmp
End Sub

chuot0106 · 30/4/15

Tôi có 1 bài tập đơn giản giành cho các bạn mới học VBA.
--------------------------------------------------------------------------------
Tìm tất cả các số chính phương trong vùng "A1:I21" và đưa kết quả ra các cell trên bảng tính
----------------------------------------
Số chính phương hay còn gọi là số hình vuông là số tự nhiên có căn bậc 2 là một số tự nhiên, hay nói cách khác, số chính phương là bình phương (lũy thừa bậc 2) của một số tự nhiên khác.

Ví dụ:

4 = 2²
9 = 3²

Quang_Hải · 30/4/15

Mình không rành lắm mấy vụ toán học nhưng nếu code cho vui thì code thế này
Code mình viết đếm ra tới 21 SNT. Quái thiệt.

PHP:

Sub abc()
Dim arr(), item, dem, sntMax
arr = [A1:H8].Value
For Each item In arr
   If item Mod 6 = 1 Or item Mod 6 = 5 Or item = 2 Then
      dem = dem + 1
      If item > sntMax Then sntMax = item
   End If
Next
MsgBox "Có " & dem & "SNT" & vbLf & "SNT lon nhat: " & sntMax
End Sub

ptm0412 · 30/4/15

chuot0106 đã viết:
Rút ngắn code đi chút:

Mã:

For Each cll In Rng dem_uoc = 0 [COLOR=#ff0000] For i = 1 To cll[/COLOR] If cll Mod i = 0 Then dem_uoc = dem_uoc + 1 Next i

Để xác định số nguyên tố bằng vòng lặp thì không cần lặp đến tận cùng như thế.

ptm0412 · 30/4/15

quanghai1969 đã viết:
Mình không rành lắm mấy vụ toán học nhưng nếu code cho vui thì code thế này
Code mình viết đếm ra tới 21 SNT. Quái thiệt.

PHP:

If item Mod 6 = 1 Or item Mod 6 = 5 Or item = 2 Then dem = dem + 1 End If

Xét điều kiện này thì 3 không phải sô nguyên tố. Trong khi đó 25, 35 lại là số nguyên tố

phihndhsp · 30/4/15

quanghai1969 đã viết:
Mình không rành lắm mấy vụ toán học nhưng nếu code cho vui thì code thế này
Code mình viết đếm ra tới 21 SNT. Quái thiệt.

PHP:

Sub abc() Dim arr(), item, dem, sntMax arr = [A1:H8].Value For Each item In arr If item Mod 6 = 1 Or item Mod 6 = 5 Or item = 2 Then dem = dem + 1 If item > sntMax Then sntMax = item End If Next MsgBox "Có " & dem & "SNT" & vbLf & "SNT lon nhat: " & sntMax End Sub

thử thuật toán này với số 49 xem sao còn số 35 nữa và một số bội của 7

chuot0106 · 30/4/15

ptm0412 đã viết:
Để xác định số nguyên tố bằng vòng lặp thì không cần lặp đến tận cùng như thế.

Chính xác là vậy. Cái này chỉ cần xét đến phần nguyên của cll/2 thôi ạ. Em cảm ơn thầy!

Bài tập VBA - Macro

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

Thành viên gắn bó

/(hông là gì!

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

File đính kèm

/(hông là gì!

Thành viên gắn bó

File đính kèm

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

Thành viên gắn bó

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

File đính kèm

0901452không62

File đính kèm

Thành viên gắn bó

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

Thành viên gắn bó

Thành viên gắn bó

Thành viên gắn bó

File đính kèm

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

Bad Excel Member

Bad Excel Member

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

Thành viên gắn bó

Đếm ngược thời gian