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

Hoale85 · 27/8/24

@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

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 ạ.

CHAOQUAY · 27/8/24

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 ạ.

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

Hoale85 · 27/8/24

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

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: 27/8/24

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

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ỉ.

Hoale85 · 27/8/24

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

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 ạ

VetMini · 27/8/24

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)

CHAOQUAY · 27/8/24

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 ạ

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

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

Hoale85

Thành viên mới

CHAOQUAY

Thành viên gắn bó

Hoale85

Thành viên mới

Hoale85

Thành viên mới

File đính kèm

VetMini

Ăn cùng góc phố

CHAOQUAY

Thành viên gắn bó

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

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