Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cl As Range
If Target.Address = "$F$1" Then
Set Cl = Range("b12:b65536").Find(Target, LookIn:=xlValues,LookAt:=xlWhole)
If Not Cl Is Nothing Then Cl.Select
End If
End Sub
Option Explicit
Sub TongVaXoaDong()
Dim WF, Rng As Range, sRng As Range, dRng As Range
Dim Dat As Date, jJ As Long, TgHMR As Double, HMR As Long
Dim MyAdd As String, DCTg As String
Set Rng = Range([A10], [A65500].End(xlUp))
Range("G12:G65500").ClearContents: Set WF = WorksheetFunction
Columns("C:C").Interior.ColorIndex = 0
Dat = WF.Min(Rng): Set dRng = [A65500]
For jJ = 0 To Date - Dat
Set sRng = Rng.Find(Dat + jJ, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
If HMR = 0 Then
HMR = sRng.Offset(, 1): DCTg = sRng.Address
TgHMR = sRng.Offset(, 2).Value
ElseIf HMR = sRng.Offset(, 1).Value Then
TgHMR = sRng.Offset(, 2).Value + TgHMR
Set dRng = Union(sRng, dRng)
sRng.Offset(, 2).Interior.ColorIndex = 38
ElseIf HMR <> sRng.Offset(, 1).Value Then
Range(DCTg).Offset(, 6).Value = TgHMR
DCTg = sRng.Address
TgHMR = sRng.Offset(, 2).Value
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
HMR = 0: TgHMR = 0: DCTg = ""
End If
Next jJ
MsgBox dRng.Address
End Sub
Bạn sửa code của bác Sealand chút xíu như sau
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cl As Range
If Target.Address = "$F$1" Then
Set Cl = Range("b12:b65536").Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cl Is Nothing Then Cl.Offset(, [f2]).Select
End If
End SubRất cám ơn bạn ,mình làm theo bạn và đã làm được đúng ý phần 1 rồi .Nhưng chỉ đúng ở file TinhTong ,mình copy code sang file khác và thay "$F$"1 bằng địa chỉ khác và phần (b12:65536) thay bằng cái khác thì code lại không chạy gì cả .Có code nào mà có thể copy sang bất cứ file nào và chỉ chỉnh 2 yếu tố là vị trí ô gõ và chỉnh dãy cần tìm kiếm là có thể dùng vô tư luôn không ? Còn phần 2 mong có tin của các bạn giúp mình.
icol = IIf([B1] = "C", 1, IIf([B1] = "D", 2, IIf([B1] = "E", 3, 4)))
If Not Intersect(Target, Range("A1:B1")) Is Nothing Then
Set Clls = [b12:b65536].Find([A1], LookIn:=xlValues, LookAt:=xlWhole)
If Not Clls Is Nothing Then Clls.Offset(, icol).Select
End If If Not Intersect(Target, Range("B4:B65535")) Is Nothing Then
If Target <> "" Then
Target.Offset(, -1) = Now()
Else
Target.Offset(, -1).Value = Empty
End If
End IfPrivate Sub Worksheet_Activate()
Dim Arr(), ArrKQ(1 To 65000, 1 To 6)
With Sheet1
Set data = .[a4].CurrentRegion
Temp = data.Value
data.Sort Key1:=.[a4], Order1:=1, Key2:=.[b4], Order1:=1, Header:=1
Arr = data.Offset(1).Value
End With
s = 1
For i = 1 To UBound(Arr) - 1
ArrKQ(s, 1) = Arr(i, 1)
ArrKQ(s, 2) = Arr(i, 2)
ArrKQ(s, 3) = ArrKQ(s, 3) + Arr(i, 3)
ArrKQ(s, 4) = ArrKQ(s, 4) + Arr(i, 4)
ArrKQ(s, 5) = ArrKQ(s, 5) + Arr(i, 5)
ArrKQ(s, 6) = ArrKQ(s, 6) + Arr(i, 6)
If (Arr(i, 1) <> Arr(i + 1, 1)) + (Arr(i, 2) <> Arr(i + 1, 2)) Then s = s + 1
Next i
Application.ScreenUpdating = False
With ActiveSheet
.[a2].CurrentRegion.Offset(1).ClearContents
.[a2].Resize(s, 6) = ArrKQ
With .[a2].CurrentRegion
.AutoFilter Field:=3, Criteria1:="="
.AutoFilter Field:=5, Criteria1:="="
.AutoFilter Field:=4, Criteria1:="="
.AutoFilter Field:=6, Criteria1:="="
End With
.[a2].Resize(s, 6).SpecialCells(12).EntireRow.Delete
.AutoFilterMode = False
End With: data = Temp
Application.ScreenUpdating = True
End Sub
End SubSắp xếp dữ liệu Nhập và hiện kết quả theo ngày tháng (hiện tại trong file đang dùng)
Thì sắp xếp dữ liệu Nhập và hiện kết quả theo HMR
With .[a2].CurrentRegion
.AutoFilter Field:=3, Criteria1:="="
.AutoFilter Field:=5, Criteria1:="="
.AutoFilter Field:=4, Criteria1:="="
.AutoFilter Field:=6, Criteria1:="="
End With
.[a2].Resize(s, 6).SpecialCells(12).EntireRow.Delete
.AutoFilterMode = False
icol = IIf([B1] = "C", 1, IIf([B1] = "D", 2, IIf([B1] = "E", 3, 4)))
If Not Intersect(Target, Range("A1:B1")) Is Nothing Then
Set Clls = [b3:b65536].Find([A1], LookIn:=xlValues, LookAt:=xlWhole)
If Not Clls Is Nothing Then Clls.Offset(, icol).Select
End If icol = IIf([B1] = "C", 1, IIf([B1] = "D", 2, IIf([B1] = "E", 3, 4)))
If Not Intersect(Target, Range("A1:B1")) Is Nothing Then
[b:b].Find([A1]).Offset(, icol).Select
End IfBác Boxyn cho em hỏi là :code này có thể copy đem đi sử dụng cho các file khác được không .Cấu trúc như nhau chỉ khác về,tên file ,tên sheet , dãy tìm kiếm (kết quả trả về sheet hiên tai ,hay sheet khác do mình chỉ định).Bác có thể cho em code dùng chung cho các file khác nhau nhưng tính năng thì tương tự như vậy.Tức là em có một file nào đó ,em xác định ô gõ vào sau đó cung cấp dãy số để tìm kiếm ,xác định cột trả về tuơng ứng với số tìm kiếm,thế là xong .Thao tác cuối cùng là gõ số vào là Enter 1 cái là đến số cần tìm ngay.Cái này em ứng dụng cho nhân viên nhập liệu (gõ số cần tìm ,enter >>đến luôn ô cần nhập )danh sách cần nhập bổ sung thông tin vào rất nhiều ,vài ngàn dòng .Dùng công cụ CTR+F và công thức Hyperlink của em thì cũng được nhưng hơi mất thời gian cho thao tác thừa.Trong tập tin đính kèm
Đoạn Code trong sheet Nhap:
PHP:icol = IIf([B1] = "C", 1, IIf([B1] = "D", 2, IIf([B1] = "E", 3, 4))) If Not Intersect(Target, Range("A1:B1")) Is Nothing Then Set Clls = [b3:b65536].Find([A1], LookIn:=xlValues, LookAt:=xlWhole) If Not Clls Is Nothing Then Clls.Offset(, icol).Select End If
sửa lại xíu xíu như sau sẽ gọn hơn chút
PHP:icol = IIf([B1] = "C", 1, IIf([B1] = "D", 2, IIf([B1] = "E", 3, 4))) If Not Intersect(Target, Range("A1:B1")) Is Nothing Then [b:b].Find([A1]).Offset(, icol).Select End If
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Clls As Range, icol As Long
If Not Intersect(Target, Range("A1:B1")) Is Nothing Then
Cells([b:b].Find([A1]).Row, [B1]).Select
End If
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
Dim Clls As Range, icol As Long
On Error Resume Next
If Not Intersect(Target, Range("A4:A5")) Is Nothing Then
Cells([C:C].Find([a4]).Row, [A5]).Select
End If
End SubThành
Thì Nhập chữ cái (tên cột, vd:A, B, C, ... hoặc a, b, c, ...) vào ô A5 sẽ được kết quả như mong muốn
.Xin lỗi bạn nha .MÌnh lấy code mới của bạn test lại thì phát sinh vấn đề là dãy số cần dò tìm từ nhỏ tới lớn thì Ok .Nhưng khi cho tìm dãy lớn giảm xuống nhỏ thì bị lỗi lấy hai số cuối của dãy đó .Nói hơi dài ,vậy bạn xem trong file mình giử kèm nha.Rất cám ơn sự nhiệt tình của bạn đó.Nói thêm về phần tính tổng mà bạn giúp mình trước đó mình test rrất ok luôn.Code bạn viết rất chuẩn,chạy nhanh cực luôn, mình cho chạy từ 7868 dòng sau khi chạy còn 5215 tiết kiệm được hơn 2653 dòng .Rất vui và ấn tượng với kết quả, khi loại bỏ được những cái dư thừa không đáng có .Bữa giờ nhìn mấy cái dòng dư thừa đó là bức xúc ,bức núc... mà chưa xly nó được .Cám ơn bạn lần nữa nha.
Cú pháp chuẩn của hàm Find:Cám ơn bạn nha.Cái vụ mà gõ số 25 ,26 gì đó là do mình lúc đầu thì mình để nhưng sau đó thấy không cần dài vậy nên xóa đi .Thành ra bạn không nhìn thấy ,mình mở ra xem lại mới thấy thế mới chết chứ lỵ(xóa đi xong save lại ,không để ý ghi chú ở trên text box)
Function Find(What, [After], [LookIn], [LookAt], [SearchOrder], [SearchDirection As XlSearchDirection = xlNext], [MatchCase], [MatchByte], [SearchFormat]) As RangeDo lược bỏ các thông số để tìm nhanh hơn nhưng với dữ liệu nhiều, trong đó lại có phần hao hao giống nhau thì hàm Find đã lược bỏ chỉ số sẽ không thể tìm chính xác
kiểm tra và cho biết kết quả nhé
.Cám ơn bạn rất rất nhiều nha..Code này hay đấy ,các bạn khác có thể lấy ứng dụng cho việc của mình.Nhớ bấm cám ơn bác boyxin một phát nha..Bye bác nha.
Híc, hơi tưng tưng "zồi", hổng hiểu sao Thầy Boy- Xỉn không dùng A, B, C mà lại 1, 2, 3..., góp vui với bạn tutientrung một cách:Cám ơn bạn nha.Cái vụ mà gõ số 25 ,26 gì đó là do mình lúc đầu thì mình để nhưng sau đó thấy không cần dài vậy nên xóa đi .Thành ra bạn không nhìn thấy ,mình mở ra xem lại mới thấy thế mới chết chứ lỵ(xóa đi xong save lại ,không để ý ghi chú ở trên text box)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, Vung, J As Long
On Error Resume Next
If Not Intersect(Target, Range("a4")) Is Nothing Then
i = Range([b7], [b50000].End(xlUp)).Rows.Count
Vung = Range([a5] & 7).Resize(i)
J = Application.WorksheetFunction.Match([a4], Vung, 0) + 6
Range([a5] & J).Select
End If
End Sub-------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Clls As Range
On Error Resume Next
If Not Intersect(Target, Range("a1:b1")) Is Nothing Then
Cells([b:b].Find([a1], , , 1, 2).Row, AscW([b1]) - IIf(AscW([b1]) > 96, 96, 64)).Select
End If
End Sub If Not Intersect(Target, Range("B4:B65535")) Is Nothing Then
If Target <> "" Then
Target.Offset(, -1) = Now()
Else
Target.Offset(, -1).Value = Empty
End If
End IfPrivate Sub Worksheet_Activate()
Dim Arr(), ArrKQ(1 To 65000, 1 To 6)
Dim i As Long, s As Long, j As Long, dk As Boolean
With Sheet1
Set data = .[a4].CurrentRegion
data.Sort Key1:=.[a4], Order1:=1, Key2:=.[b4], Order1:=1, Header:=1
Arr = data.Offset(1).Value
End With
s = 1
For i = 1 To UBound(Arr) - 1
dk = False
For j = 3 To 6
If Arr(i, j) > 0 Then dk = True: Exit For
Next
If dk = True Then
ArrKQ(s, 1) = Arr(i, 1): ArrKQ(s, 2) = Arr(i, 2)
For j = 3 To 6
ArrKQ(s, j) = ArrKQ(s, j) + Arr(i, j)
Next
If (Arr(i, 1) <> Arr(i + 1, 1)) + (Arr(i, 2) <> Arr(i + 1, 2)) Then s = s + 1
End If
Next i
Application.ScreenUpdating = False
With ActiveSheet
.[a2].CurrentRegion.Offset(1).ClearContents
.[a2].Resize(s, 6) = ArrKQ
End With: data = Temp
Application.ScreenUpdating = True
End SubCám ơn bác đã tham gia vào bài này .Ở bài http://www.giaiphapexcel.com/forum/...Tách-chuỗi-có-5-điều-kiện&p=260074#post260074
,"tửu lượng không cao ,nhưng cũng khiến vài người đi ngủ" đấy..Thưc ra thì hôm sinh nhật GPE em cũng muốn tham gia offline rồi .Nhưng hôm đấy công ty cho đi du lịch nên đành chịu.Dung nhan các bác thì e cũng đã được chiêm ngưỡng ,sự nhiệt tình thì còn hơn cả chữ nhiệt tình nữa.Dung nhan của em thì cũng có trong kỷ yếu GPE rồi .Vì thế e cũng mong có dịp để lai rai và đàm đạo cùng các bác.Nếu các bác không chê em thì nếu có việc gì ,Alo 1 phát là có mặt ngay .
