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.
