Những ai đã từng xem qua bài viết này: Giới thiệu Cơ bản về vòng lặp For . . . next của sư phụ ptm0412 giờ hãy cùng làm 1 vài bài tập từ đơn giản đến nâng cao nhé
Xin mở màn bằng 1 bài tập sau:
Bài tập 01:
Hãy tính xem từ năm 1900 đến nay có bao nhiêu ngày thuộc dạng THỨ SÁU NGÀY 13
------------------------
Các bạn ai có bài tập gì hay xin post lên đây nhé! Cảm ơn
Em sửa lại đoạn code theo hướng dẫn của Bác HYen17 như sau:
Mã:
Sub Tinhngay()
Dim tongngay As Long, nghi As Integer, le As Integer
Dim i As Long, j As Date
Cells.Clear
tongngay = DateSerial(2010, 12, 31) - DateSerial(2010, 8, 19)
le = 1: nghi = 0
For i = 19 To 26
If Weekday(DateSerial(2010, 8, i)) = 1 Then
For j = DateSerial(2010, 8, i) To DateSerial(2010, 12, 31) Step 7
With ActiveCell
.Value = j
nghi = nghi + ActiveCell.Count
.Offset(1, 0).Select
End With
Next
End If
Next
If Weekday(DateSerial(2010, 9, 2)) <> 1 Then ActiveCell = DateSerial(2010, 9, 2)
MsgBox "Tong ngay lam viec la: " & tongngay - le - nghi
End Sub
(*) Sau lại nhốt chung vòng lặp sau vô trong vòng lặp trước vậy?
Nếu gặp ngay ngày CN từ đầu, có fải bạn fí fạm 6 lần lặp không cần thiết không nào?
Nên thoát khỏi nó ngay khi gặp ngày CN chứ; Tuy thêm 1 dòng lệnh, nhưng thưởng giảm đi được khoảng gần nữa đọan đường trong vòng lặp thứ nhật đó bạn.
Em sửa lại đoạn code theo hướng dẫn của Bác HYen17 như sau:
Mã:
Sub Tinhngay()
Dim tongngay As Long, nghi As Integer, le As Integer
Dim i As Long, j As Date
Cells.Clear
tongngay = DateSerial(2010, 12, 31) - DateSerial(2010, 8, 19)
le = 1: nghi = 0
For i = 19 To 26
If Weekday(DateSerial(2010, 8, i)) = 1 Then
For j = DateSerial(2010, 8, i) To DateSerial(2010, 12, 31) Step 7
With ActiveCell
.Value = j
nghi = nghi + ActiveCell.Count
.Offset(1, 0).Select
End With
Next
End If
Next
If Weekday(DateSerial(2010, 9, 2)) <> 1 Then ActiveCell = DateSerial(2010, 9, 2)
MsgBox "Tong ngay lam viec la: " & tongngay - le - nghi
End Sub
Đây là code liệt kê tất cả những ngày đi làm ra cột A, từ đầu năm 2010 đến cuối năm 2010 (không tính chủ nhât)
PHP:
Sub Tinhngay()
Dim i As Long, j As Long
With Range("A:A")
.ClearContents
.NumberFormat = "dd/mm/yyyy"
For i = DateSerial(2010, 1, 1) To DateSerial(2010, 12, 31)
If Weekday(i, 1) > 1 Then
j = j + 1
.Cells(j, 1) = i
End If
Next
End With
End Sub
Code này chưa tính đến nghỉ lễ ---> Bạn cứ cải tiến nhé
(Nhìn qua nhìn lại chỉ thấy có mỗi bạn MinhCong ---> cái vụ VBA này xem ra ít người khoái nhỉ?)
Buồn quá, và ngứa ngáy nữa, nên đành post câu c bài 04 lên để tham khảo.
Như đã gợi ý ở câu b, ta dùng 1 gia số dòng và 1 gia số cột.
Xin giải thích 1 tẹo về chạy ca rô: Chạy ca rô là chạy ô vừa lên hoặc xuống, vừa chạy qua phải (hoặc trái), mỗi lần dịch chuyển 1 vị trí dòng và 1 vị trí cột. Xuống thì chỉ số dòng tăng và ngược lại. Qua phải thì chỉ số cột tăng và ngược lại.
Vậy gia số thêm vào cho dòng và cột là các số 1 và -1.
Trước tiên tô màu ô trên cùng bên trái vị trí là dòng i = 1 cột j = 1, hướng đi xuống về bên phải, gia số dòng K = 1 và gia số cột L = 1:
PHP:
i = 1: j = 1
K = 1, L = 1
Cells (i, j).Interior.ColorIndex = 15
Ô kế tiếp có vị trí dòng và cột là i = i + K, j = j + L
Nếu sau khi tô, vị trí ô vừa tô là cạnh rìa của hình chữ nhật, thì đổi chiều:
- Đụng cạnh rìa bên phải: L đổi từ 1 thành -1 để chạy qua trái
- Đụng cạnh rìa bên trái: L đổi từ -1 thành 1 để chạy qua phải
- Đụng cạnh dưới: K đổi từ 1 thành -1 để chạy lên
- Đụng cạnh trên: K đổi từ -1 thành 1 để chạy xuống.
Chưa cần tính tối ưu code làm gì, và cũng chưa cần bẫy lỗi làm gì, bạn đã có 1 đoạn code hoàn chỉnh và ngắn gọn. Với hình chữ nhật không đặc biệt (nghĩa là không bị trả về quỹ đạo cũ), bảo đảm sẽ tô toàn bộ khung chữ nhật thành carô.
Vậy tô bao nhiêu ô? Theo lý thuyết thì tô 1/2 tổng số ô, nhưng do chạy kiểu này, mỗi ô là 1 giao điểm của 2 đường chéo nên sẽ bị chạy qua 2 lần. Vậy Chọn số vòng lặp là tổng số ô và = dòng x cột. Có thể dư, có thể thiếu, nhưng tạm xài.
Code sau đây tô hình chữ nhật không đặc biệt 15 x 24:
PHP:
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
______________________________________
Sub colorRun()
i = 1: j = 1
K = 1: L = 1
For d = 1 To 15 * 24
Sleep (15)
Cells(i, j).Interior.ColorIndex = 15
i = i + K
j = j + L
If i = 15 Or i = 1 Then K = -K
If j = 24 Or j = 1 Then L = -L
Next
End Sub
1. Xin hỏi trường hợp code của anh số hàng bằng số cột thì tô màu chỉ có 1 đường chéo
2. Xin anh giải thích giúp đoạn code: Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Không phải đâu anh, chẳng qua chưa làm được thì chưa post lên thôi, nhưng theo dõi và học tập thường xuyên, kính mong mấy anh giúp đỡ, đây là lớp học thuận tiên nhất
Cảm ơn các anh rất nhiều, chúc các anh luôn khỏe.
2. Mở rộng tô hình chữ nhật lấy kích thước từ bàn phím: (Hình đặc biệt vẫn chưa bẫy lỗi, lỗi gì thì thử nhiều kích thước khác nhau sẽ thấy)
PHP:
Sub colorRun1()
CRows = InputBox("So dong?")
CCols = InputBox("So cot?")
If CRows = 1 Or CCols = 1 Then Exit Sub
i = 1: j = 1
K = 1: L = 1
For d = 1 To CRows * CCols
Sleep (15)
Cells(i, j).Interior.ColorIndex = 15
i = i + K
j = j + L
If i = CRows Or i = 1 Then K = -K
If j = CCols Or j = 1 Then L = -L
Next
End Sub
3. Mở rộng tô vùng chọn bất kỳ không phải bắt đầu từ A1: (vẫn chưa sửa gì cho hình chữ nhật đặc biệt)
PHP:
Sub colorRun2()
CRows = Selection.Rows.Count
CCols = Selection.Columns.Count
If CRows = 1 Or CCols = 1 Then Exit Sub
i = 1: j = 1
K = 1: L = 1
For d = 1 To CRows * CCols
Sleep (15)
With Selection
.Cells(i, j).Interior.ColorIndex = 15
i = i + K
j = j + L
If i = CRows Or i = 1 Then K = -K
If j = CCols Or j = 1 Then L = -L
End With
Next
End Sub
Mọi người thử so sánh với code của mình làm xem? (Code của ndu và huuthang cũng chưa tô hết cho hình đặc biệt)
1. Xin hỏi trường hợp code của anh số hàng bằng số cột thì tô màu chỉ có 1 đường chéo
2. Em chạy thấy báo lỗi dòng Sleep(15): Xin anh giải thích giúp
Camr ơn anh
Như đã nói từ đầu topic, làm từ dễ đến khó, bẫy lỗi cho mọi hình chữ nhật không phải đơn giản, mới chỉ có mình RollOver đưa file lên tô hình chữ nhật bất kỳ, ndu và Huuthang cũng chưa. Trước mắt suy luận chuyện dễ trước.
Lỗi dòng Sleep do có lẽ viehoai không copy dòng khai báo trên cùng. Tải file bài trên nhé.
CRows * CCols
hay 24*15
Con số này bạn lây ở đâu ra vậy, hình như vừa thừa vừa thiếu? đây là số hay, tôi mới tiếp xúc VBA , không biết nên hỏi, nếu không đúng, thì bỏ qua
tôi cũng bị lỗi giống thế, vậy hàm Sleep này mình nghĩ ra, hãy viết ở đâu?
Chưa cần tính tối ưu code làm gì, và cũng chưa cần bẫy lỗi làm gì, bạn đã có 1 đoạn code hoàn chỉnh và ngắn gọn. Với hình chữ nhật không đặc biệt (nghĩa là không bị trả về quỹ đạo cũ), bảo đảm sẽ tô toàn bộ khung chữ nhật thành carô.
Vậy tô bao nhiêu ô? Theo lý thuyết thì tô 1/2 tổng số ô, nhưng do chạy kiểu này, mỗi ô là 1 giao điểm của 2 đường chéo nên sẽ bị chạy qua 2 lần. Vậy Chọn số vòng lặp là tổng số ô và = dòng x cột. Có thể dư, có thể thiếu, nhưng tạm xài.
Vậy nên tôi lấy tổng số ô = dài x rộng dùng làm số lần lặp.
Vì vẫn có 1 số ô nằm trên rìa hình chữ nhật không được tô 2 lần, nên hơi dư. Nếu không tô hết thì dư khá nhiều. Tuy vậy, không đến nỗi phải ngồi chờ suông lâu quá.
Hàm sleep là lấy trong thư viện Office ra, nó không có sẵn trong VBA nên phải khai báo đến thư viện (Lib) Kernel32.dll
mục đích dùng hàm này là để Pause code 1 khoảng thời gian tính bằng milisecond.
Em xin mạnh dạng đưa code, xin các anh chị giúp đỡ:
1. Chọn cell để xác định hàng và cột cuối cùng của vùng cần tô màu nền caro --> chạy code
2. (phần hỏi) Để tô nền caro cho một range bất kỳ (không xuất phát A1) bằng cách quét chọn range bất kỳ nào đó. Muốn vậy cần xác định hàng và cột đầu tiên của Range đó bằng cách nào? (cell đầu tiên của Range đang chọn). Xin các anh chị giúp đỡ
Cảm ơn các anh chị.
Em xin mạnh dạng đưa code, xin các anh chị giúp đỡ:
1. Chọn cell để xác định hàng và cột cuối cùng của vùng cần tô màu nền caro --> chạy code
2. (phần hỏi) Để tô nền caro cho một range bất kỳ (không xuất phát A1) bằng cách quét chọn range bất kỳ nào đó. Muốn vậy cần xác định hàng và cột đầu tiên của Range đó bằng cách nào? (cell đầu tiên của Range đang chọn). Xin các anh chị giúp đỡ
Cảm ơn các anh chị.
Viehoai có thể thử sửa code cho vùng chọn bất kỳ. Dù không phải tô kiểu bida, nhưng kết quả cũng là tô carô. Coi như bài tập phụ vậy.
Tuy nhiên, không cần thiết phải làm như vậy cho cực.
Đối với 1 vùng chọn hình chữ nhật đơn (nghĩa là không tô chọn nhiều vùng 1 lúc), VBA có thể dùng câu lệnh như sau để đối xử như cả sheet:
Selection.Cells(1, 1) tương đương với ô đầu tiên của vùng chọn. Viết đầy đủ là Sheet1.Selection.Cells(1, 1). Có thể dùng biến i, j bắt đầu từ 1 như cũ.
Đối với sheet thì là Sheet1.Cells(1, 1) nghĩa là ô A1, viết tắt là Cells(1, 1) vì mặc định selection đang là cả sheet.
Viehoai có thể thử sửa code cho vùng chọn bất kỳ. Dù không phải tô kiểu bida, nhưng kết quả cũng là tô carô. Coi như bài tập phụ vậy.
Tuy nhiên, không cần thiết phải làm như vậy cho cực.
Đối với 1 vùng chọn hình chữ nhật đơn (nghĩa là không tô chọn nhiều vùng 1 lúc), VBA có thể dùng câu lệnh như sau để đối xử như cả sheet:
Selection.Cells(1, 1) tương đương với ô đầu tiên của vùng chọn. Viết đầy đủ là Sheet1.Selection.Cells(1, 1). Có thể dùng biến i, j bắt đầu từ 1 như cũ.
Đối với sheet thì là Sheet1.Cells(1, 1) nghĩa là ô A1, viết tắt là Cells(1, 1) vì mặc định selection đang là cả sheet.
Cảm ơn anh rất nhiều em hiểu sâu hơn về vấn đề này. Tuy nhiên Anh Mỹ giải thích giúp em cách 1 sao có thêm Resize(1,1)?
Em xin sửa lại code theo cách quét vùng chọn bất kỳ ---> chạy code
(*) Sau lại nhốt chung vòng lặp sau vô trong vòng lặp trước vậy?
Nếu gặp ngay ngày CN từ đầu, có fải bạn fí fạm 6 lần lặp không cần thiết không nào?
Nên thoát khỏi nó ngay khi gặp ngày CN chứ; Tuy thêm 1 dòng lệnh, nhưng thưởng giảm đi được khoảng gần nữa đọan đường trong vòng lặp thứ nhật đó bạn.
Em sửa lại đoạn code theo góp ý của Bác ChanhTQ@ như sau:
Mã:
Sub Tinhngay()
Dim tongngay As Long, nghi As Integer, le As Integer
Dim i As Long, j As Date
Cells.ClearContents
tongngay = DateSerial(2010, 12, 31) - DateSerial(2010, 8, 19): le = 1
For i = 19 To 25
If Weekday(DateSerial(2010, 8, i)) = 1 Then Exit For
Next
For j = DateSerial(2010, 8, i) To DateSerial(2010, 12, 31) Step 7
With [COLOR=Red]ActiveCell[/COLOR]
.NumberFormat = "dd/mm/yyyy"
.Value = j
nghi = nghi + ActiveCell.Count
.Offset(1, 0).Select
End With
Next
If Weekday(DateSerial(2010, 9, 2)) <> 1 Then ActiveCell = DateSerial(2010, 9, 2)
MsgBox "Tong ngay lam viec la: " & tongngay - le - nghi
End Sub
Tuy nhiên chỗ ActiveCell muốn nó nằm ở cột A thì làm sao nhỉ? Không lẽ phải thêm 1 vòng lặp nữa?
Em sửa lại đoạn code theo góp ý của Bác ChanhTQ@ như sau:
Mã:
Sub Tinhngay()
Dim tongngay As Long, nghi As Integer, le As Integer
Dim i As Long, j As Date
Cells.ClearContents
tongngay = DateSerial(2010, 12, 31) - DateSerial(2010, 8, 19): le = 1
For i = 19 To 25
If Weekday(DateSerial(2010, 8, i)) = 1 Then Exit For
Next
For j = DateSerial(2010, 8, i) To DateSerial(2010, 12, 31) Step 7
With [COLOR=red]ActiveCell[/COLOR]
.NumberFormat = "dd/mm/yyyy"
.Value = j
nghi = nghi + ActiveCell.Count
.Offset(1, 0).Select
End With
Next
If Weekday(DateSerial(2010, 9, 2)) <> 1 Then ActiveCell = DateSerial(2010, 9, 2)
MsgBox "Tong ngay lam viec la: " & tongngay - le - nghi
End Sub
Tuy nhiên chỗ ActiveCell muốn nó nằm ở cột A thì làm sao nhỉ? Không lẽ phải thêm 1 vòng lặp nữa?
Một cách để cho kết quả từ A1:
_ Tạo một biến, thí dụ : Dim K as Integer
_ With ActiveCell thay bằng With [A1].Offset(K) hoặc With Cells(K + 1, 1) _ Thay.Offset(1, 0).Select bằng K= K + 1
Câu C bài số 4 trong trường hợp tổng quát, giả sử tô 1 vùng bất kỳ bởi 2 màu, khi đó ta sẽ thấy tập các ô có tính chất (Cột+Dòng) là 1 số chẵn sẽ được tô 1 màu, tập các ô có tính chất (Cột+Dòng) là 1 số lẻ được tô 1 màu. Như vậy nếu để tô mà không cần theo quy luật về đường đi thì các bạn chỉ cần duyệt và tô theo tính chất trên sẽ rất đơn giản. Còn về quy luật đường đi thì theo cách của bác ptm theo tôi là chuẩn nhất rồi. Vậy để giải quyết bài này theo hướng tổng quát nhất ta có thể đi theo mấy bước như sau:
1. Duyệt tất cả các ô, đẩy tất cả các ô cần tô(có cùng tính chất Dòng+Cột chẵn hoặc lẻ) vào 1 danh sách
2. Chọn ngẫu nhiên 1 ô trong danh sách, thực hiện tô màu cho ô này, sau khi tô thì loại ô đó ra khỏi danh sách, sau khi loại khỏi danh sách mà hết danh sách thì dừng.
3. Thực hiện di chuyển từ ô vừa tô theo nguyên tắc di chuyển(di chuyển đến ô nào thì kiểm tra nếu ô đó có trong danh sách thì loại ô đó ra khỏi danh sách), gặp dấu hiệu bị lặp thì dừng di chuyển và quay lại bước 2.
Tôi xin gửi các bạn code của cả 3 câu của bài 4 như sau:
Câu a
Mã:
Sub Row1()
Dim iValue As Long, iCol As Long, iRow As Long, iRows As Long, iCols As Long
iCols = InputBox("Nhap so cot:")
iRows = InputBox("Nhap so dong:")
For iValue = 1 To iRows * iCols
iRow = (iValue - 1) \ iCols + 1
iCol = (iValue - 1) Mod iCols + 1
Cells(iRow, iCol).Interior.ColorIndex = 4
Sleep 100
Next
End Sub
Câu b
Mã:
Sub Row2()
Dim iValue As Long, iCol As Long, iRow As Long, iRows As Long, iCols As Long
iCols = InputBox("Nhap so cot:")
iRows = InputBox("Nhap so dong:")
For iValue = 1 To iRows * iCols
iRow = (iValue - 1) \ iCols + 1
iCol = IIf(iRow Mod 2 = 1, (iValue - 1) Mod iCols + 1, iCols - ((iValue - 1) Mod iCols))
Cells(iRow, iCol).Interior.ColorIndex = 4
Sleep 100
Next
End Sub
Câu c
Mã:
Sub Caro1()
Dim iValue As Long, iCol As Long, iRow As Long, iRows As Long, iCols As Long, objDic As New
Dictionary, EpRow As Long, EpCol As Long
iCols = InputBox("Nhap so cot:")
iRows = InputBox("Nhap so dong:")
For iValue = 1 To iCols * iRows
iRow = (iValue - 1) \ iCols + 1
iCol = (iValue - 1) Mod iCols + 1
If ((iRow + iCol) Mod 2 = 0) Then objDic.Add iValue, iValue
Next
Randomize
Do While objDic.Count > 0
EpRow = IIf(Rnd() > 0.5, 1, -1)
EpCol = IIf(Rnd() > 0.5, 1, -1)
iValue = Int(Rnd() * objDic.Count)
iRow = (objDic.Keys(iValue) - 1) \ iCols + 1
iCol = (objDic.Keys(iValue) - 1) Mod iCols + 1
Cells(iRow, iCol).Interior.ColorIndex = 4
Sleep 200
objDic.Remove objDic.Keys(iValue)
Do While objDic.Count > 0
If iRow + EpRow < 1 Or iRow + EpRow > iRows Then EpRow = EpRow * (-1)
If iCol + EpCol < 1 Or iCol + EpCol > iCols Then EpCol = EpCol * (-1)
iRow = iRow + EpRow
iCol = iCol + EpCol
iValue = (iRow - 1) * iCols + iCol
Cells(iRow, iCol).Interior.ColorIndex = 4
Sleep 100
If objDic.Exists(iValue) Then
objDic.Remove iValue
Else
If iRow = 1 Or iRow = iRows Or iCol = 1 Or iCol = iCols Then Exit Do
End If
Loop
Loop
MsgBox "OK!"
End Sub
Các bạn thử cải tiến thành 3 câu như sau:
Câu a thành tô theo từng cột từ trên xuống dưới
Câu b thành tô theo từng cột từ trên xuống dưới rồi lại từ dưới lên trên
Câu c thành tô với 2 màu, khi nào tô hết màu thứ nhất thì tô tiếp màu thứ 2 để thành 1 bàn cờ với 2 màu.
Câu a và b chr cần thay đổi vị trí của cells(iRow,iCol) thành cells(iCol,iRow) là được.
Mã:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Câu a:
Mã:
Sub Row1()
Dim iValue As Long, iCol As Long, iRow As Long, iRows As Long, iCols As Long
Cells.Clear
iCols = InputBox("Nhap so cot:")
iRows = InputBox("Nhap so dong:")
For iValue = 1 To iRows * iCols
iRow = (iValue - 1) Mod iCols + 1
iCol = (iValue - 1) \ iCols + 1
Cells(iRow, iCol).Interior.ColorIndex = 4
Sleep 50
Next
End Sub
Câu b:
Mã:
Sub Row2()
Dim iValue As Long, iCol As Long, iRow As Long, iRows As Long, iCols As Long
Cells.Clear
iCols = InputBox("Nhap so cot:")
iRows = InputBox("Nhap so dong:")
For iValue = 1 To iRows * iCols
iCol = (iValue - 1) \ iCols + 1
iRow = IIf(iCol Mod 2 = 1, (iValue - 1) Mod iCols + 1, iCols - ((iValue - 1) Mod iCols))
Cells(iRow, iCol).Interior.ColorIndex = 4
Sleep 100
Next
End Sub
Đoạn code tô caro sao Em chạy nó bị báo lỗi ở khai báo objDic As New Dictionary nhỉ?
