Nhờ các bác tối ưu hóa code trong sheet2 với ạ. Em cảm ơn ạ

  • Thread starter Thread starter Hoale85
  • Ngày gửi Ngày gửi
Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
CHAOQUAY đã viết:
@Hoale85
Bài này chỉ sửa lại code bài 1 để làm rõ hơn cách tính nên vẫn giữ nguyên sql như cũ.
Bạn xem file đính kèm để hiệu chỉnh lại cho phù hợp
Mã: 
Option Explicit

Sub A_0_xxx()
Dim ArrID
Dim sql As String
Dim cn As Object, rs As Object
Dim Tam
Dim Kq()
Dim DicTH As Object
Dim i, j, k

'ket noi
Set cn = CreateObject("ADODB.connection")
Set rs = CreateObject("ADODB.recordset")
With cn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(39) & ThisWorkbook.FullName & Chr(39) & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
.Open
End With

'khai bao mang ket qua & dicTH.
'DicTH: key = Stt trong sheet data. Item = so thu tu dong trong danh sach quan huyen can tra cuu ( sheet2.Rang("C6:D35"))
With Sheet1
    k = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim Kq(1 To k - 1, 1 To 2)
End With
Set DicTH = CreateObject("Scripting.Dictionary")

'trich loc theo danh sach yeu cau
With Sheet2
    ArrID = .Range("C6", Sheet2.Range("D6").End(xlDown))
   
    For i = 1 To UBound(ArrID)
        k = .Range("A6") & ArrID(i, 1) & .Range("A7") & ArrID(i, 2)
        sql = Right(k, Len(k) - Len("mi_sql")) & "%'"
       
        rs.Open sql, cn
       
        Tam = rs.GetRows '<-- lay ket qua ve mang. ket qua tra ve theo tung cot
        For j = 0 To UBound(Tam, 2)
            k = Tam(0, j) 'k = Stt khach hang theo sheet data
            DicTH(k) = i 'key = stt khach hang, item = chi so dong quan huyen tinh toan ( i )
        Next j
       
        rs.Close
    Next i
End With

'huy ket noi
cn.Close
Set cn = Nothing
Set rs = Nothing

'tra quan huyen theo cot Stt cua Sheet data
Tam = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown))
For i = 1 To UBound(Tam)
    If DicTH.exists(Tam(i, 1)) Then
        k = DicTH(Tam(i, 1))
        Kq(i, 1) = ArrID(k, 1)
        Kq(i, 2) = ArrID(k, 2)
    End If
Next i

'dien ket qua xuong sheet
With Sheet1
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)).Clear
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With

MsgBox "Ket thuc"
End Sub
Nhấp chuột vào đây để mở rộng...
Sub tinh_90()
Dim i&, lr&, j&, dc&, tr&
Application.ScreenUpdating = False

lr = Sheet2.Range("V" & Rows.Count).End(xlUp).Row
For i = 3 To lr
Sheet2.Range("K2").ClearContents
Sheet2.Range("Z2:AA5000").ClearContents
If Sheet2.Range("L2").Value = Sheet2.Range("V" & i).Value Then
Sheet2.Range("K2").Value = Sheet2.Range("u" & i).Value
Sheet2.Range("B5").Value = Sheet2.Range("B2").Value & Sheet2.Range("K2").Value
Sheet2.Range("B3").Value = Sheet2.Range("B5").Value & Sheet2.Range("P3").Value
Sheet2.Range("B4").Value = Sheet2.Range("B3").Value & Sheet2.Range("L2").Value & Sheet2.Range("P5").Value

Sheet2.Range("X1").Value = Sheet2.Range("B4").Value
Dim keycells As Range
Set keycells = ActiveSheet.Range("X1")

If InStr(keycells.Value2, "mi_sql") > 0 Then
sql = Right(keycells.Value2, Len(keycells.Value2) - Len("mi_sql"))
run_sql_sub sql



End If
dc = Sheet2.Range("Y" & Rows.Count).End(xlUp).Row

For j = 2 To dc
If Sheet2.Range("Y" & j).Value <> "" Then
Sheet2.Range("Z" & j).Value = Sheet2.Range("K2").Value
Sheet2.Range("AA" & j).Value = Sheet2.Range("L2").Value
End If
Next j
End If
For tr = 2 To 9246
If Sheet1.Range("G" & tr).Value = "" Then
Sheet1.Range("G" & tr).Value = Application.WorksheetFunction.IfError(Application.VLookup(Sheet1.Range("c" & tr), Sheet2.Range("X2:AA" & dc), 3, 0), "")
Sheet1.Range("H" & tr).Value = Application.WorksheetFunction.IfError(Application.VLookup(Sheet1.Range("c" & tr), Sheet2.Range("X2:AA" & dc), 4, 0), "")
End If
Next tr
Next i
Application.ScreenUpdating = True

End Sub
Em viết code này chạy cũng tạm tạm anh ạ.
 
Hoale85 đã viết:
Sub tinh_90()
Dim i&, lr&, j&, dc&, tr&
Application.ScreenUpdating = False

lr = Sheet2.Range("V" & Rows.Count).End(xlUp).Row
For i = 3 To lr
Sheet2.Range("K2").ClearContents
Sheet2.Range("Z2:AA5000").ClearContents
If Sheet2.Range("L2").Value = Sheet2.Range("V" & i).Value Then
Sheet2.Range("K2").Value = Sheet2.Range("u" & i).Value
Sheet2.Range("B5").Value = Sheet2.Range("B2").Value & Sheet2.Range("K2").Value
Sheet2.Range("B3").Value = Sheet2.Range("B5").Value & Sheet2.Range("P3").Value
Sheet2.Range("B4").Value = Sheet2.Range("B3").Value & Sheet2.Range("L2").Value & Sheet2.Range("P5").Value

Sheet2.Range("X1").Value = Sheet2.Range("B4").Value
Dim keycells As Range
Set keycells = ActiveSheet.Range("X1")

If InStr(keycells.Value2, "mi_sql") > 0 Then
sql = Right(keycells.Value2, Len(keycells.Value2) - Len("mi_sql"))
run_sql_sub sql



End If
dc = Sheet2.Range("Y" & Rows.Count).End(xlUp).Row

For j = 2 To dc
If Sheet2.Range("Y" & j).Value <> "" Then
Sheet2.Range("Z" & j).Value = Sheet2.Range("K2").Value
Sheet2.Range("AA" & j).Value = Sheet2.Range("L2").Value
End If
Next j
End If
For tr = 2 To 9246
If Sheet1.Range("G" & tr).Value = "" Then
Sheet1.Range("G" & tr).Value = Application.WorksheetFunction.IfError(Application.VLookup(Sheet1.Range("c" & tr), Sheet2.Range("X2:AA" & dc), 3, 0), "")
Sheet1.Range("H" & tr).Value = Application.WorksheetFunction.IfError(Application.VLookup(Sheet1.Range("c" & tr), Sheet2.Range("X2:AA" & dc), 4, 0), "")
End If
Next tr
Next i
Application.ScreenUpdating = True

End Sub
Em viết code này chạy cũng tạm tạm anh ạ.
Nhấp chuột vào đây để mở rộng...
Việc tra cứu này nếu lọc tỉnh/thành phố trước, quận huyện sau có lẽ sẽ cải thiện tốc độ đáng kế, lọc đồng thời có lẽ sẽ chậm hơn
 
CHAOQUAY đã viết:
@Hoale85
Bài này chỉ sửa lại code bài 1 để làm rõ hơn cách tính nên vẫn giữ nguyên sql như cũ.
Bạn xem file đính kèm để hiệu chỉnh lại cho phù hợp
Mã: 
Option Explicit

Sub A_0_xxx()
Dim ArrID
Dim sql As String
Dim cn As Object, rs As Object
Dim Tam
Dim Kq()
Dim DicTH As Object
Dim i, j, k

'ket noi
Set cn = CreateObject("ADODB.connection")
Set rs = CreateObject("ADODB.recordset")
With cn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(39) & ThisWorkbook.FullName & Chr(39) & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
.Open
End With

'khai bao mang ket qua & dicTH.
'DicTH: key = Stt trong sheet data. Item = so thu tu dong trong danh sach quan huyen can tra cuu ( sheet2.Rang("C6:D35"))
With Sheet1
    k = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim Kq(1 To k - 1, 1 To 2)
End With
Set DicTH = CreateObject("Scripting.Dictionary")

'trich loc theo danh sach yeu cau
With Sheet2
    ArrID = .Range("C6", Sheet2.Range("D6").End(xlDown))
   
    For i = 1 To UBound(ArrID)
        k = .Range("A6") & ArrID(i, 1) & .Range("A7") & ArrID(i, 2)
        sql = Right(k, Len(k) - Len("mi_sql")) & "%'"
       
        rs.Open sql, cn
       
        Tam = rs.GetRows '<-- lay ket qua ve mang. ket qua tra ve theo tung cot
        For j = 0 To UBound(Tam, 2)
            k = Tam(0, j) 'k = Stt khach hang theo sheet data
            DicTH(k) = i 'key = stt khach hang, item = chi so dong quan huyen tinh toan ( i )
        Next j
       
        rs.Close
    Next i
End With

'huy ket noi
cn.Close
Set cn = Nothing
Set rs = Nothing

'tra quan huyen theo cot Stt cua Sheet data
Tam = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown))
For i = 1 To UBound(Tam)
    If DicTH.exists(Tam(i, 1)) Then
        k = DicTH(Tam(i, 1))
        Kq(i, 1) = ArrID(k, 1)
        Kq(i, 2) = ArrID(k, 2)
    End If
Next i

'dien ket qua xuong sheet
With Sheet1
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)).Clear
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With

MsgBox "Ket thuc"
End Sub
Nhấp chuột vào đây để mở rộng...
code tuyệt vời quá bác ơi, em đang ngồi ngâm cứu code của bác.
Bài đã được tự động gộp:

CHAOQUAY đã viết:
@Hoale85
Bài này chỉ sửa lại code bài 1 để làm rõ hơn cách tính nên vẫn giữ nguyên sql như cũ.
Bạn xem file đính kèm để hiệu chỉnh lại cho phù hợp
Mã: 
Option Explicit

Sub A_0_xxx()
Dim ArrID
Dim sql As String
Dim cn As Object, rs As Object
Dim Tam
Dim Kq()
Dim DicTH As Object
Dim i, j, k

'ket noi
Set cn = CreateObject("ADODB.connection")
Set rs = CreateObject("ADODB.recordset")
With cn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(39) & ThisWorkbook.FullName & Chr(39) & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
.Open
End With

'khai bao mang ket qua & dicTH.
'DicTH: key = Stt trong sheet data. Item = so thu tu dong trong danh sach quan huyen can tra cuu ( sheet2.Rang("C6:D35"))
With Sheet1
    k = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim Kq(1 To k - 1, 1 To 2)
End With
Set DicTH = CreateObject("Scripting.Dictionary")

'trich loc theo danh sach yeu cau
With Sheet2
    ArrID = .Range("C6", Sheet2.Range("D6").End(xlDown))
   
    For i = 1 To UBound(ArrID)
        k = .Range("A6") & ArrID(i, 1) & .Range("A7") & ArrID(i, 2)
        sql = Right(k, Len(k) - Len("mi_sql")) & "%'"
       
        rs.Open sql, cn
       
        Tam = rs.GetRows '<-- lay ket qua ve mang. ket qua tra ve theo tung cot
        For j = 0 To UBound(Tam, 2)
            k = Tam(0, j) 'k = Stt khach hang theo sheet data
            DicTH(k) = i 'key = stt khach hang, item = chi so dong quan huyen tinh toan ( i )
        Next j
       
        rs.Close
    Next i
End With

'huy ket noi
cn.Close
Set cn = Nothing
Set rs = Nothing

'tra quan huyen theo cot Stt cua Sheet data
Tam = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown))
For i = 1 To UBound(Tam)
    If DicTH.exists(Tam(i, 1)) Then
        k = DicTH(Tam(i, 1))
        Kq(i, 1) = ArrID(k, 1)
        Kq(i, 2) = ArrID(k, 2)
    End If
Next i

'dien ket qua xuong sheet
With Sheet1
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)).Clear
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With

MsgBox "Ket thuc"
End Sub
Nhấp chuột vào đây để mở rộng...
Bác ơi sao em thêm dữ liệu vào sheet2 cột C, D thì báo lỗi bác nhỉ.
1724746294160.png
 
Lần chỉnh sửa cuối:
CHAOQUAY đã viết:
@Hoale85
Bài này chỉ sửa lại code bài 1 để làm rõ hơn cách tính nên vẫn giữ nguyên sql như cũ.
Bạn xem file đính kèm để hiệu chỉnh lại cho phù hợp
Mã: 
Option Explicit

Sub A_0_xxx()
Dim ArrID
Dim sql As String
Dim cn As Object, rs As Object
Dim Tam
Dim Kq()
Dim DicTH As Object
Dim i, j, k

'ket noi
Set cn = CreateObject("ADODB.connection")
Set rs = CreateObject("ADODB.recordset")
With cn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(39) & ThisWorkbook.FullName & Chr(39) & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
.Open
End With

'khai bao mang ket qua & dicTH.
'DicTH: key = Stt trong sheet data. Item = so thu tu dong trong danh sach quan huyen can tra cuu ( sheet2.Rang("C6:D35"))
With Sheet1
    k = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim Kq(1 To k - 1, 1 To 2)
End With
Set DicTH = CreateObject("Scripting.Dictionary")

'trich loc theo danh sach yeu cau
With Sheet2
    ArrID = .Range("C6", Sheet2.Range("D6").End(xlDown))
   
    For i = 1 To UBound(ArrID)
        k = .Range("A6") & ArrID(i, 1) & .Range("A7") & ArrID(i, 2)
        sql = Right(k, Len(k) - Len("mi_sql")) & "%'"
       
        rs.Open sql, cn
       
        Tam = rs.GetRows '<-- lay ket qua ve mang. ket qua tra ve theo tung cot
        For j = 0 To UBound(Tam, 2)
            k = Tam(0, j) 'k = Stt khach hang theo sheet data
            DicTH(k) = i 'key = stt khach hang, item = chi so dong quan huyen tinh toan ( i )
        Next j
       
        rs.Close
    Next i
End With

'huy ket noi
cn.Close
Set cn = Nothing
Set rs = Nothing

'tra quan huyen theo cot Stt cua Sheet data
Tam = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown))
For i = 1 To UBound(Tam)
    If DicTH.exists(Tam(i, 1)) Then
        k = DicTH(Tam(i, 1))
        Kq(i, 1) = ArrID(k, 1)
        Kq(i, 2) = ArrID(k, 2)
    End If
Next i

'dien ket qua xuong sheet
With Sheet1
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)).Clear
    .Range("G2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With

MsgBox "Ket thuc"
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ anh, em không hiểu nó báo lỗi ở đâu bác ạ. Bác xem và chỉ lỗi giúp em với ạ
 

File đính kèm

Bạn dùng debug, lấy mấy cây SQL ấy, đưa lên đây thì người ta mới xem được nó chậm ở chỗ nào.
Bên trong code, chúng rối như nòng nọc, khó mà định.

SQL được MS chú ý cho mấy chỗ Join, Union, Group, và Sort thôi. Tất cả các lệnh khác nó đều có thể chạy rất chậm.
(Union All chỉ gộp dữ liệu, Union gồm sort và lọc Unique)
 
Hoale85 đã viết:
Dạ anh, em không hiểu nó báo lỗi ở đâu bác ạ. Bác xem và chỉ lỗi giúp em với ạ
Nhấp chuột vào đây để mở rộng...
Bạn tìm & sửa như bên dưới
Mã: 
'        Tam = rs.GetRows '<-- lay ket qua ve mang. ket qua tra ve theo tung cot
'        For j = 0 To UBound(Tam, 2)
'            k = Tam(0, j) 'k = Stt khach hang theo sheet data
'            DicTH(k) = i 'key = stt khach hang, item = chi so dong quan huyen tinh toan ( i )
'        Next j
        If Not rs.EOF And Not rs.BOF Then
            Tam = rs.GetRows '<-- lay ket qua ve mang. ket qua tra ve theo tung cot
            For j = 0 To UBound(Tam, 2)
                k = Tam(0, j) 'k = Stt khach hang theo sheet data
                DicTH(k) = i 'key = stt khach hang, item = chi so dong quan huyen tinh toan ( i )
            Next j
        End If

---
Có lẽ bạn nên xóa các dòng tại cột C có tên trùng với cột D
 
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

CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
3
Đọc
415
YenTon
Y
1
Phát triển một VBE trong Delphi để tạo một cửa sổ công cụ.
Trả lời
9
Đọc
214
125479980
1
C
Code Set password File Excel
    • Cười
Trả lời
5
Đọc
157
SA_DQ
SA_DQ
vn81206
TRA CỨU MÃ SỐ THUẾ CÁ NHÂN QUA EXCEL
    • Buồn
2 3
Trả lời
44
Đọc
13K
HeSanbi
HeSanbi
T
Tính tổng các sheet, dùng hàm sumif kết hợp với indirect
Trả lời
2
Đọc
41
tungoctram
T
T
Xin giúp em copy cột C ở tất cả các sheet vào file import_template. Em cảm ơn ạ.
Trả lời
5
Đọc
130
HUONGHCKT
H
tutepp
Lỗi không mở được file Excel, chỉ mở được khi dùng Ultraview
Trả lời
7
Đọc
102
tutepp
tutepp
dangtuan1212
Mình cần hỗ trợ in excel 2 mặt căn lề trái phải theo trang chẵn lẻ
Trả lời
2
Đọc
54
dangtuan1212
dangtuan1212
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
302
Đọc
20K
bimbebeo
bimbebeo
X
Tự động giãn dòng và ẩn các dòng bị bỏ trống
Trả lời
7
Đọc
309
HUONGHCKT
H
T
Cố định các dòng merger cell để khi in không bị ẩn mất nội dung khi dùng Autofit row height
Trả lời
1
Đọc
51
yaaasoo01
Y
HeSanbi
  • Đã giải quyết
HÀM FITROW - Co giãn dòng tự động tối ưu nhất cho Excel v2.44 (*28/12/2024)
    • Thích
    • Yêu thích
2 3
Trả lời
53
Đọc
22K
minhminh040499
minhminh040499
GPE-Trợ Lý
[GPE] TALK SHOW NHỮNG ĐIỀU NHỎ TÁC DỤNG LỚN TRONG PIVOT TABLE
    • Thích
Trả lời
1
Đọc
219
GPE-Trợ Lý
GPE-Trợ Lý
Hoàng Trọng Nghĩa
  • Suggestion Suggestion
Tặng các bạn file "QUAY SỐ TRÚNG THƯỞNG"
    • Thích
Trả lời
9
Đọc
4K
anthanh32
anthanh32
KTS NGUYEN DU
Các bác có biết chỉnh mục trống này về dạng word cơ bản không ạ.
Trả lời
5
Đọc
157
KTS NGUYEN DU
KTS NGUYEN DU
giaiphap
Chia sẻ cách tạo gợi ý cho hàm trong Excel bằng thư viện ExcelDna.
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
6
Đọc
2K
Phương Nguyễn 89
Phương Nguyễn 89
hahuykhuong
  • Question Question
link file pdf hóa đơn bằng vba
Trả lời
3
Đọc
178
hahuykhuong
hahuykhuong
Manhhung90
  • Question Question
Xin giúp chuyển dữ liệu từ cột dọc sang hàng ngang theo điều kiện
    • Buồn
Trả lời
10
Đọc
263
Manhhung90
Manhhung90
M
  • Question Question
Code VBA tìm mã kiện gỗ còn tồn kho
Trả lời
7
Đọc
321
BuiQuangThuan
B
HeSanbi
  • Đã giải quyết
ExplorerXL - Quản lý thư mục với Excel: tìm, đổi tên, sao chép, di chuyển và xóa
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
80
Đọc
16K
ngochienbmt
N
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới
Back
Top Bottom