Nhờ ACE sửa giúp code tìm kiếm (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

tuoigiyeuem

Thành viên chính thức
Tham gia
19/12/08
Bài viết
99
Được thích
4
Em chạy code dưới đây để tìm kiếm. Nhưng do viết hàm luôn lên Cell nên file tính nặng và chạy khá lâu. Nhờ ACE giúp em sửa với.
Mã: 
   Sub timkiem()   Dim i As Integer
   For i = 8 To 14860


        Cells(i, 3).Value = "=IFERROR(LOOKUP(2,1/((TTCSD!R5C2:R1162C2=RC[28])*(TTCSD!R5C11:R1162C11=RC[29])),TTCSD!R5C1:R1162C1),"""")"
    Next i
   End Sub
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tuoigiyeuem đã viết:
Em chạy code dưới đây để tìm kiếm. Nhưng do viết hàm luôn lên Cell nên file tính nặng và chạy khá lâu. Nhờ ACE giúp em sửa với.
Mã: 
   Sub timkiem()   Dim i As Integer
   For i = 8 To 14860


        Cells(i, 3).Value = "=IFERROR(LOOKUP(2,1/((TTCSD!R5C2:R1162C2=RC[28])*(TTCSD!R5C11:R1162C11=RC[29])),TTCSD!R5C1:R1162C1),"""")"
    Next i
   End Sub
Nhấp chuột vào đây để mở rộng...
Bạn thử:
PHP: 
Sub timkiem2()
    Dim LR As Long
    LR = Range("AE" & Rows.Count).End(3).Row
    Range("C8:C" & LR).Formula = "=IFERROR(LOOKUP(2,1/((TTCSD!R5C2:R1162C2=RC[28])*(TTCSD!R5C11:R1162C11=RC[29])),TTCSD!R5C1:R1162C1),"""")"
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
tuoigiyeuem đã viết:
Em chạy code dưới đây để tìm kiếm. Nhưng do viết hàm luôn lên Cell nên file tính nặng và chạy khá lâu. Nhờ ACE giúp em sửa với.
Mã: 
   Sub timkiem()   Dim i As Integer
   For i = 8 To 14860


        Cells(i, 3).Value = "=IFERROR(LOOKUP(2,1/((TTCSD!R5C2:R1162C2=RC[28])*(TTCSD!R5C11:R1162C11=RC[29])),TTCSD!R5C1:R1162C1),"""")"
    Next i
   End Sub
Nhấp chuột vào đây để mở rộng...

Bạn gởi file, nói rõ yêu cầu để viết code lấy đúng kết quả gán xuống Sheet, chứ viết code để gán công thức Excel vào sheet (hơn ngàn dòng) cũng không cải thiện được tốc độ và dung lượng file.
 
Upvote 0
Ba Tê đã viết:
Bạn gởi file, nói rõ yêu cầu để viết code lấy đúng kết quả gán xuống Sheet, chứ viết code để gán công thức Excel vào sheet (hơn ngàn dòng) cũng không cải thiện được tốc độ và dung lượng file.
Nhấp chuột vào đây để mở rộng...
Em gửi file lên nhờ ACE giúp đỡ.
Kết quả em muốn là : dò tìm theo 2 điều kiện : Tên ( cột B), DiaChi B ( cột K) - bên sheet TTCSD để lấy cột Mã CSD (cột A) sang cột C bên sheet TongHop. ( em dùng hàm Lookup trên ra kết quả như mong muốn nhưng vì là viết hàm lên Cell nên file chạy chậm và nặng )
 

File đính kèm

Upvote 0
tuoigiyeuem đã viết:
Em gửi file lên nhờ ACE giúp đỡ.
Kết quả em muốn là : dò tìm theo 2 điều kiện : Tên ( cột B), DiaChi B ( cột K) - bên sheet TTCSD để lấy cột Mã CSD (cột A) sang cột C bên sheet TongHop. ( em dùng hàm Lookup trên ra kết quả như mong muốn nhưng vì là viết hàm lên Cell nên file chạy chậm và nặng )
Nhấp chuột vào đây để mở rộng...

Code của bạn đây, bạn kiểm tra lại so với công thức xem sao.
PHP: 
Public Sub GPE()
Dim Dic As Object, sArr(), tArr(), dArr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TTCSD")
    tArr = .Range("A5", .Range("A65536").End(xlUp)).Resize(, 11).Value
End With
For I = 1 To UBound(tArr)
    Tem = tArr(I, 2) & "#" & tArr(I, 11)
    Dic.Item(Tem) = tArr(I, 1)
Next I
With Sheets("TONGHOP")
    sArr = .Range("AE8", .Range("AE65536").End(xlUp)).Resize(, 2).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr)
        Tem = sArr(I, 1) & "#" & sArr(I, 2)
        If Dic.Exists(Tem) Then dArr(I, 1) = Dic.Item(Tem)
    Next I
    .Range("C8").Resize(I - 1) = dArr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
tuoigiyeuem đã viết:
Em gửi file lên nhờ ACE giúp đỡ.
Kết quả em muốn là : dò tìm theo 2 điều kiện : Tên ( cột B), DiaChi B ( cột K) - bên sheet TTCSD để lấy cột Mã CSD (cột A) sang cột C bên sheet TongHop. ( em dùng hàm Lookup trên ra kết quả như mong muốn nhưng vì là viết hàm lên Cell nên file chạy chậm và nặng )
Nhấp chuột vào đây để mở rộng...
Nếu công thức của bạn đúng( Vì máy cơ quan của tôi đời Office 2003 không thử được), bạn thử lại Code bài #2 xem sao.
 
Upvote 0
Cám ơn anh. Nhờ anh sửa hộ em code này với.
khi em gõ giá trị vào cột C hoặc ctrl+c rồi ctrl + v thì sự kiên Worksheet_Change tự động chạy dò tìm.
Nhưng khi em dùng chuột kéo để copy giá trị ở 1 ô trên cột C xuống nhiều dòng dưới thì sự kiện Worksheet_Change không chạy. Anh giúp em bổ sung code với
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
tuoigiyeuem đã viết:
Cám ơn anh. Nhờ anh sửa hộ em code này với.
khi em gõ giá trị vào cột C hoặc ctrl+c rồi ctrl + v thì sự kiên Worksheet_Change tự động chạy dò tìm.
Nhưng khi em dùng chuột kéo để copy giá trị ở 1 ô trên cột C xuống nhiều dòng dưới thì sự kiện Worksheet_Change không chạy. Anh giúp em bổ sung code với
Nhấp chuột vào đây để mở rộng...

Nhờ ACE giúp em với ạ.
 
Upvote 0
tuoigiyeuem đã viết:
Nhờ ACE giúp em với ạ.
Nhấp chuột vào đây để mở rộng...

cột A sheet"TTCSD" bạn đánh số theo thứ tự nha.
kiểm tra lại các cột, hình như tôi để sai thứ tự
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo thoat
    Dim rng, cll As Range
    Dim i, k As Long
    Dim arr(1 To 60000, 1 To 43)

        Set rng = Intersect(Target, Range("c8:c60000"))
        If Not rng Is Nothing Then ' KETQUA
         
            With Sheets("TTCSD")
                Sarr = .Range(.[A5], .[A60000].End(3)).Resize(, 21).Value2
            End With
             
            For Each cll In rng
                k = k + 1: i = cll.Value
                If k <= UBound(Sarr) Then
                    arr(k, 1) = Sarr(i, 1) ' stt
                    arr(k, 2) = Sarr(i, 2) ' ho ten csd
                    arr(k, 4) = Sarr(i, 4) ' nam sinh
                    arr(k, 5) = Sarr(i, 6) 'cmnd
                    arr(k, 7) = Sarr(i, 8) ' noi cap
                    arr(k, 8) = Sarr(i, 19) 'shk
                    arr(k, 9) = Sarr(i, 20) 'ngay cap hk
                    arr(k, 10) = Sarr(i, 18) 'noi cap hk
                    arr(k, 11) = Sarr(i, 9) 'xam canh
                    arr(k, 12) = Sarr(i, 10) 'dia chi CSD
                    arr(k, 13) = Sarr(i, 5) 'dan toc
                    arr(k, 15) = Sarr(i, 12) 'ten vo/chong
                    arr(k, 16) = Sarr(i, 14) ' nam sinh
                    arr(k, 17) = Sarr(i, 16) 'cmnd vo-chong
                    arr(k, 18) = Sarr(i, 17) 'ngay cap
                    arr(k, 19) = Sarr(i, 18) 'noi cap
                    arr(k, 21) = Sarr(i, 15) 'dan toc
                    arr(k, 43) = Sarr(i, 21) 'giay to kem theo
                End If
            Next
            If k Then rng.Cells(1, 1).Resize(k, 43).Value = arr
         End If
thoat:
Application.EnableEvents = True
If Err Then MsgBox Err.Description
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Cám ơn anh nhiều.}}}}}}}}}}}}}}}}}}}}}}}}}
Let'GâuGâu đã viết:
cột A sheet"TTCSD" bạn đánh số theo thứ tự nha.
kiểm tra lại các cột, hình như tôi để sai thứ tự
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo thoat
    Dim rng, cll As Range
    Dim i, k As Long
    Dim arr(1 To 60000, 1 To 43)

        Set rng = Intersect(Target, Range("c8:c60000"))
        If Not rng Is Nothing Then ' KETQUA
         
            With Sheets("TTCSD")
                Sarr = .Range(.[A5], .[A60000].End(3)).Resize(, 21).Value2
            End With
             
            For Each cll In rng
                k = k + 1: i = cll.Value
                If k <= UBound(Sarr) Then
                    arr(k, 1) = Sarr(i, 1) ' stt
                    arr(k, 2) = Sarr(i, 2) ' ho ten csd
                    arr(k, 4) = Sarr(i, 4) ' nam sinh
                    arr(k, 5) = Sarr(i, 6) 'cmnd
                    arr(k, 7) = Sarr(i, 8) ' noi cap
                    arr(k, 8) = Sarr(i, 19) 'shk
                    arr(k, 9) = Sarr(i, 20) 'ngay cap hk
                    arr(k, 10) = Sarr(i, 18) 'noi cap hk
                    arr(k, 11) = Sarr(i, 9) 'xam canh
                    arr(k, 12) = Sarr(i, 10) 'dia chi CSD
                    arr(k, 13) = Sarr(i, 5) 'dan toc
                    arr(k, 15) = Sarr(i, 12) 'ten vo/chong
                    arr(k, 16) = Sarr(i, 14) ' nam sinh
                    arr(k, 17) = Sarr(i, 16) 'cmnd vo-chong
                    arr(k, 18) = Sarr(i, 17) 'ngay cap
                    arr(k, 19) = Sarr(i, 18) 'noi cap
                    arr(k, 21) = Sarr(i, 15) 'dan toc
                    arr(k, 43) = Sarr(i, 21) 'giay to kem theo
                End If
            Next
            If k Then rng.Cells(1, 1).Resize(k, 43).Value = arr
         End If
thoat:
Application.EnableEvents = True
If Err Then MsgBox Err.Description
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Anh ơi giúp em với. Em muốn giữ lại dữ liệu ở những cột có sẵn thông tin rồi không phải do lookup lấy sang ( cột: Z -> cột AS, cột AU đến cột BF ).
 

File đính kèm

Upvote 0
tuoigiyeuem đã viết:
Anh ơi giúp em với. Em muốn giữ lại dữ liệu ở những cột có sẵn thông tin rồi không phải do lookup lấy sang ( cột: Z -> cột AS, cột AU đến cột BF ).
Nhấp chuột vào đây để mở rộng...

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo thoat
    Dim rng, cll As Range
    Dim i, k As Long
    Dim arr As Variant

        Set rng = Intersect(Target, Range("c8:c60000"))
        If Not rng Is Nothing Then ' KETQUA
         If Target.Columns.Count > 1 Then GoTo thoat
            With Sheets("TTCSD")
                Sarr = .Range(.[A5], .[A60000].End(3)).Resize(, 22).Value2
            End With
            Union(rng.Offset(, 1).Resize(, 22), rng.Offset(, 43)).ClearContents
            arr = rng.Resize(, 56).Value2
            For Each cll In rng
                k = k + 1: i = cll.Value
                If i <= UBound(Sarr) Then
                    arr(k, 1) = Sarr(i, 1) ' stt
                    arr(k, 2) = Sarr(i, 2) ' ho ten csd
                    arr(k, 3) = Sarr(i, 3) ' gioi tinh
                    arr(k, 5) = Sarr(i, 4) ' nam sinh
                    arr(k, 6) = Sarr(i, 6) 'cmnd
                    arr(k, 7) = Sarr(i, 7) ' ngay cap
                    arr(k, 8) = Sarr(i, 8) 'noi cap cmnd
                    arr(k, 9) = Sarr(i, 19) 'shk
                    arr(k, 10) = Sarr(i, 20) 'ngay cap hk
                    arr(k, 11) = Sarr(i, 21) 'noi cap hk
                    arr(k, 12) = Sarr(i, 9) 'xam canh
                    arr(k, 13) = Sarr(i, 10) 'dia chi CSD
                    arr(k, 14) = Sarr(i, 5) 'dan toc
                    arr(k, 16) = Sarr(i, 12) 'ten vo/chong
                    arr(k, 17) = Sarr(i, 14) ' nam sinh
                    arr(k, 18) = Sarr(i, 16) 'cmnd vo-chong
                    arr(k, 19) = Sarr(i, 17) 'ngay cap
                    arr(k, 20) = Sarr(i, 18) 'noi cap
                    arr(k, 22) = Sarr(i, 15) 'dan toc
                    arr(k, 44) = Sarr(i, 22) 'giay to kem theo
                End If
            Next
            If k Then rng.Cells(1, 1).Resize(k, 56).Value = arr
         End If
thoat:
Application.EnableEvents = True
If Err Then MsgBox Err.Description
End Sub
 
Upvote 0
Anh ơi giúp em với. Giờ em nhập Mã CSD ở bên sheet TTCSD không theo thứ tự lần lượt thì bên cột Tổng Hợp k dò tìm đc.
 

File đính kèm

Upvote 0
tuoigiyeuem đã viết:
ACE nào giúp em với ạ.
Nhấp chuột vào đây để mở rộng...

tôi chưa hiểu lắm
tức là cột A sheet "TTCSD" không được nhập theo thứ tự? nếu không sort theo thứ tự thì nó không đúng rồi
có 2 cách: viết code cho nó sort lại hoặc dùng phương thức Find
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo thoat
    Dim rng, cll, ma_cds As Range
    Dim i, k As Long
    Dim arr As Variant

        Set rng = Intersect(Target, Range("c8:c60000"))
        If Not rng Is Nothing Then ' KETQUA
         If Target.Columns.Count > 1 Then GoTo thoat
            With Sheets("TTCSD")
                sArr = .Range(.[A5], .[A60000].End(3)).Resize(, 22).Value2
            End With
            Union(rng.Offset(, 1).Resize(, 22), rng.Offset(, 22)).ClearContents
            arr = rng.Resize(, 22).Value2
            For Each cll In rng
                k = k + 1 ': i = cll.Value
                Set ma_cds = Sheets("TTCSD").[a4:a60000].Find(cll.Value, , , 1)
                If Not ma_cds Is Nothing Then i = ma_cds.Value
                If i <= UBound(sArr) Then
                    arr(k, 1) = sArr(i, 1) ' stt
                    arr(k, 2) = sArr(i, 2) ' ho ten csd
                    arr(k, 3) = sArr(i, 3) ' gioi tinh
                    arr(k, 5) = sArr(i, 4) ' nam sinh
                    arr(k, 6) = sArr(i, 6) 'cmnd
                    arr(k, 7) = sArr(i, 7) ' ngay cap
                    arr(k, 8) = sArr(i, 8) 'noi cap cmnd
                    arr(k, 9) = sArr(i, 19) 'shk
                    arr(k, 10) = sArr(i, 20) 'ngay cap hk
                    arr(k, 11) = sArr(i, 21) 'noi cap hk
                    arr(k, 12) = sArr(i, 9) 'xam canh
                    arr(k, 13) = sArr(i, 10) 'dia chi CSD
                    arr(k, 14) = sArr(i, 5) 'dan toc
                    arr(k, 16) = sArr(i, 12) 'ten vo/chong
                    arr(k, 17) = sArr(i, 14) ' nam sinh
                    arr(k, 18) = sArr(i, 16) 'cmnd vo-chong
                    arr(k, 19) = sArr(i, 17) 'ngay cap
                    arr(k, 20) = sArr(i, 18) 'noi cap
                    arr(k, 22) = sArr(i, 15) 'dan toc
                    'arr(k, 44) = sArr(i, 22) 'giay to kem theo
                End If
            Next
            If k Then rng.Cells(1, 1).Resize(k, 22).Value = arr
         End If
thoat:
Application.EnableEvents = True
If Err Then MsgBox Err.Description
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Dạ vấn đề là có 1 số dòng ở sheet TTCSD trong quá trình làm việc có thể phải xóa bớt đi nên sẽ không thể theo sort theo theo số thứ tự đc. Anh có thể sửa giúp em theo cách Find đc không ạ
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác. (2 người xem)
Trả lời
3
Đọc
90
hoangtuan.net
hoangtuan.net
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
13
Đọc
237
SA_DQ
SA_DQ
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
3
Đọc
145
hoangtuaotrang_hp_vn
H
A
ExTools : Hơn 60 tính năng bổ sung cho Excel
    • Thích
Trả lời
3
Đọc
9K
mangat060083
M
anhtuan1066
  • Question Question
Đọc số thành chữ có phần thập phân
Trả lời
12
Đọc
8K
caocat
C
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính (1 người xem)
Trả lời
2
Đọc
106
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
152
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
91
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD (1 người xem)
    • Cười
Trả lời
0
Đọc
108
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
1
Đọc
85
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người?
    • Cười
Trả lời
4
Đọc
86
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA (2 người xem)
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng
Trả lời
3
Đọc
106
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++ (1 người xem)
    • Thích
Trả lời
0
Đọc
124
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
237
Tuấn Bụng Bự
Tuấn Bụng Bự
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
1
Đọc
87
BuiQuangThuan
B
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

  • Không tìm thấy.

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom