أكاديمية الصقر للتدريب


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





حل مشكلة فتح الملف اكثر من مرة عند استخدام تقنية ADO

الاصدقاء الاكارم تحية طيبة الكود التالي يقوم بعملية فلترة البيانات و نسخها الى صفحة جديدة باستخدام ADO و RecordSet المشك ..



18-05-2022 01:14 صباحا
محمد ايمن
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 18-05-2022
رقم العضوية : 24295
المشاركات : 3
الجنس : ذكر
تاريخ الميلاد : 13-2-1988
قوة السمعة : 10
 offline 

الاصدقاء الاكارم تحية طيبة

الكود التالي يقوم بعملية فلترة البيانات و نسخها الى صفحة جديدة باستخدام ADO و RecordSet

المشكلة : في حال وجود اي مصنف اكسل مفتوح سابقا و تم فتح الملف في مثيل جديد الكود يقوم بفتح المصنف مرة ثانية
للقراءة فقط و الكود يصبح بطيئ جدا جدا

كيف يمكن حل المشكلة

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

 
  Animation.gif   تحميل gif Animation.gif مرات التحميل :(1)
الحجم :(886.444) KB
 
  المصنف2.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(42.64) KB




21-05-2022 05:31 مساء
مشاهدة مشاركة منفردة [1]
محمد ايمن
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 18-05-2022
رقم العضوية : 24295
المشاركات : 3
الجنس : ذكر
تاريخ الميلاد : 13-2-1988
قوة السمعة : 10
 offline 
look/images/icons/i1.gif حل مشكلة فتح الملف اكثر من مرة عند استخدام تقنية ADO
للرفع




الكلمات الدلالية
استخدام ، اكثر ، الملف ، مشكلة ، تقنية ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 01:07 صباحا