Xin chào các thành viên trên diễn đàn, tôi có 1 file đính kèm muốn nhờ các thành viên giúp đỡ là " Tìm các ô trên và dưới ô màu đỏ ", trong file có các yêu cầu.Rất mong có câu trả lời của các thành viên.
Tôi xin chân thành cám ơn.
Xin chào các thành viên trên diễn đàn, tôi có 1 file đính kèm muốn nhờ các thành viên giúp đỡ là " Tìm các ô trên và dưới ô màu đỏ ", trong file có các yêu cầu.Rất mong có câu trả lời của các thành viên.
Tôi xin chân thành cám ơn.
Cám ơn bạn rất nhiều. Còn 1 chút thắc mắc nữa nếu được thì tốt quá, khi hiện các số cần tìm thì nó xuất hiện từ trên xuống dưới " có thể thêm từ trái qua phải được không ?"
Cám ơn bạn rất nhiều. Còn 1 chút thắc mắc nữa nếu được thì tốt quá, khi hiện các số cần tìm thì nó xuất hiện từ trên xuống dưới " có thể thêm từ trái qua phải được không ?"
Private Sub CommandButton1_Click()
Dim Cll As Range, Vung As Range
Dim Tim(1 To 1000) As Variant
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
Set Vung = Range("B3:M32")
For Each Cll In Vung
If Cll.Interior.ColorIndex = 3 Then
i = i + 1
Tim(i) = Cells(Cll.Row - 1, Cll.Column).Value
End If
Next
For j = 1 To i
Range("P" & j + 14).Value = Tim(j)
Next
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Dim Cll As Range, Vung As Range
Dim Tim(1 To 1000) As Variant
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
Set Vung = Range("B3:M32")
For Each Cll In Vung
If Cll.Interior.ColorIndex = 3 Then
i = i + 1
Tim(i) = Cells(Cll.Row + 1, Cll.Column).Value
End If
Next
For j = 1 To i
Range("Q" & j + 14).Value = Tim(j)
Next
Application.ScreenUpdating = True
End Sub
---------------------------------------
Mặc dù mình mới tìm hiểu về VBA nhưng mình thấy cũng không nên viết code lặp lại thao tác như vậy. Cấu trúc 2 commandbutton gần giống nhau mình có thể viết trường hợp bài này như thế này không (mượn code của bạn)
[GPECODE=vb]Private Sub CommandButton1_Click()
Range("P15500").ClearContents
FindUpDown Range("B3:M32"), True
End Sub
'===========================
Private Sub CommandButton2_Click()
Range("Q15:Q500").ClearContents
FindUpDown Range("B3:M32"), False
End Sub
'===========================
Sub FindUpDown(ByVal rTable As Range, Optional bUpDown As Boolean)
Dim i As Long, j As Long, k As Long
Dim Tim(1 To 1000) As Variant
Dim Cll As Range
Application.ScreenUpdating = False
For Each Cll In rTable
If Cll.Interior.ColorIndex = 3 Then
i = i + 1
If bUpDown Then
k = Cll.Row - 1 '<= không cần dùng k nhưng do thói quen
Else
k = Cll.Row + 1
End If
Tim(i) = Cells(k, Cll.Column).Value
End If
Next
For j = 1 To i
Range("Q" & j + 14).Offset(, bUpDown).Value = Tim(j)
Next
Application.ScreenUpdating = True
End Sub
[/GPECODE]
Mà thấy dùng mảng kiểu này cứ thế nào ấy???
Ngoài ra còn trường hợp ví dụ vùng chứa cả dòng 1 (A1:H15 chẳng hạn) mà ô B1 màu đỏ thì tất nhiên là không có dòng 0 rồi, hoặc ở dòng trên cùng/ dưới cùng của vùng tìm kiếm - vậy thì sẽ thêm dk như thế nào?
Mọi người vui lòng góp ý về 2 diểm trên
.....................................
Ngoài ra còn trường hợp ví dụ vùng chứa cả dòng 1 (A1:H15 chẳng hạn) mà ô B1 màu đỏ thì tất nhiên là không có dòng 0 rồi, hoặc ở dòng trên cùng/ dưới cùng của vùng tìm kiếm - vậy thì sẽ thêm dk như thế nào?
Mọi người vui lòng góp ý về 2 diểm trên
Hic, xem lại bài 5 thì mình viết code thật là "lửng lơ"
Viết lại. Mong mọi người góp ý
[GPECODE=vb]Private Sub CommandButton1_Click()
Set rTable = Range("B3:M32")
Set desRange = Range("P15")
desRange.Resize(500).ClearContents
FindUpDown rTable, desRange, True
End Sub
'===========================
Private Sub CommandButton2_Click()
Set rTable = Range("B3:M32")
Set desRange = Range("Q15")
desRange.Resize(500).ClearContents
FindUpDown rTable, desRange, False
End Sub
'===========================
Sub FindUpDown(ByVal rTable As Range, ByVal desRange As Range, Optional bUpDown As Boolean)
Dim i As Long, j As Long
Dim sArray(1 To 1000) As Variant '<= cu chuoi
Dim Cll As Range
Application.ScreenUpdating = False
For Each Cll In rTable
If Cll.Interior.ColorIndex = 3 Then
i = i + 1
If bUpDown Then
If Cll.Row <> 1 Or Cll.Row <> rTable.Rows(1).Row Then sArray(i) = Cells(Cll.Row - 1, Cll.Column).Value
Else
If Cll.Row <> rTable.Rows(rTable.Rows.Count).Row Then sArray(i) = Cells(Cll.Row + 1, Cll.Column).Value 'or Cll.Row <> 65536 '<= rat it xay ra, du lieu ko dai den het bang
End If
End If
Next
For j = 1 To i '<= cu chuoi
desRange.Offset(j).Value = sArray(j)
Next
Application.ScreenUpdating = True
End Sub
[/GPECODE]
Xin chào các thành viên trên diễn đàn, tôi có 1 file đính kèm muốn nhờ các thành viên giúp đỡ là " Tìm các ô trên và dưới ô màu đỏ ", trong file có các yêu cầu.Rất mong có câu trả lời của các thành viên.
Tôi xin chân thành cám ơn.
Không biết cái vụ TÌM TRÊN, TÌM DƯỚI này áp dụng gì trong thực tế nhỉ? Bởi vì tôi thấy nó.. buồn cười sao ấy (mặc dù viết code hoàn toàn không có vấn đề)
Không biết cái vụ TÌM TRÊN, TÌM DƯỚI này áp dụng gì trong thực tế nhỉ? Bởi vì tôi thấy nó.. buồn cười sao ấy (mặc dù viết code hoàn toàn không có vấn đề)
Từ hôm qua đến nay có cái này rất thuận tiện.(bình thường làm mất một ngày mới xong, khi có cái này....1 h đồng hồ. " Tìm trước và sau ngày trả nợ, VD: nợ A 3 cái hóa đơn có ghi ngày là 1,2,3,... nhưng chỉ có tiền trả hóa đơn ngày 2 thôi (màu đỏ), tìm ngày nợ còn lại......" Cái vụ này nó có liên quan đến bài :Câu đố tháng 12-2007 - chủ đề Solver
Từ hôm qua đến nay có cái này rất thuận tiện.(bình thường làm mất một ngày mới xong, khi có cái này....1 h đồng hồ. " Tìm trước và sau ngày trả nợ, VD: nợ A 3 cái hóa đơn có ghi ngày là 1,2,3,... nhưng chỉ có tiền trả hóa đơn ngày 2 thôi (màu đỏ), tìm ngày nợ còn lại......" Cái vụ này nó có liên quan đến bài :Câu đố tháng 12-2007 - chủ đề Solver
500").ClearContents
