الاصدقاء الاكارم تحية طيبة
الكود التالي يقوم بعملية فلترة البيانات و نسخها الى صفحة جديدة باستخدام ADO و RecordSet
المشكلة : في حال وجود اي مصنف اكسل مفتوح سابقا و تم فتح الملف في مثيل جديد الكود يقوم بفتح المصنف مرة ثانية
للقراءة فقط و الكود يصبح بطيئ جدا جدا
كيف يمكن حل المشكلة
CODE
Sub testado()
On Error GoTo ErrSub
Dim SDate As Date
Dim EDate As Date
Dim Lr1 As Long
Dim ii As Integer
Dim VBalance As Double
Dim Vresult1 As Double
Dim VResult2 As Double
Dim VName As String
Dim query As String
Dim rs As New ADODB.Recordset
Dim connection As New ADODB.connection
connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & _
";Extended Properties=""Excel 12.0;HDR=Yes;"";"
'connection.Open
Application.ScreenUpdating = False
Sheets("ملخص الارصدة").EnableCalculation = False
Lr1 = Sheets("الميزانية").Range("A:A").End(xlDown).Row
Sheets("ملخص الارصدة").Range("A7:A" & Sheets("ملخص الارصدة").Cells(Rows.Count, "A").End(xlUp).Row).EntireRow.Delete
Sheets("ملخص الارصدة").Range("B6:F6").ClearContents
SDate = Date - Weekday(Date, vbSaturday) + 1
EDate = Date - Weekday(Date, vbSaturday) + 7
For i = 2 To Lr1
VName = Sheets("الميزانية").Range("A" & i).Value
ii = Sheets("ملخص الارصدة").Cells(Rows.Count, "A").End(xlUp).Row
ii = ii + 1
Vresult1 = WorksheetFunction.SumIfs(Sheet26.Range("b2:b10000"), Sheet26.Range("a2:a10000"), VName, Sheet26.Range("e2:e10000"), "<" & CDbl(SDate))
VResult2 = WorksheetFunction.SumIfs(Sheet26.Range("c2:c10000"), Sheet26.Range("a2:a10000"), VName, Sheet26.Range("e2:e10000"), "<" & CDbl(SDate))
VBalance = Vresult1 - VResult2
If VBalance <> 0 Then
Sheets("ملخص الارصدة").Range("E" & ii) = "مدور"
Sheets("ملخص الارصدة").Range("B" & ii) = VName
Sheets("ملخص الارصدة").Range("C" & ii) = VBalance
ii = ii + 1
query = "select * from [subrs$] where [الاسم]='" & VName & "' and [التاريخ]>=" & CDbl(SDate)
rs.Open query, connection
Sheets("ملخص الارصدة").Select
Do While Not rs.EOF
Sheets("ملخص الارصدة").Range("B" & ii) = rs.Fields(0)
Sheets("ملخص الارصدة").Range("C" & ii) = rs.Fields(1)
Sheets("ملخص الارصدة").Range("D" & ii) = rs.Fields(2)
Sheets("ملخص الارصدة").Range("E" & ii) = rs.Fields(3)
Sheets("ملخص الارصدة").Range("F" & ii) = rs.Fields(4)
ii = ii + 1
rs.MoveNext
Loop
Sheets("ملخص الارصدة").Range("B" & ii) = "0"
Sheets("ملخص الارصدة").Range("A" & ii & ":F" & ii).Interior.Color = RGB(255, 255, 0)
rs.Close
End If
Application.ScreenUpdating = True
Sheets("ملخص الارصدة").Range("A" & ii - 1).Select
DoEvents
Application.ScreenUpdating = False
Next i
Sheets("ملخص الارصدة").EnableCalculation = True
Sheets("ملخص الارصدة").Calculate
connection.Close
Application.ScreenUpdating = True
MsgBox "تم", vbInformation + vbMsgBoxRight, "المبدع لأنظمة المحاسبة"
ErrSub:
If Err.Number = 3705 Then
connection.Close
connection.Open
Resume Next
End If
If Err.Number <> 0 Then MsgBox Err.Number & vbCrLf & Err.Description
End Sub
حل مشكلة فتح الملف اكثر من مرة عند استخدام تقنية ADO
