logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
بليغ البتول ali mohamed ali-- لا تميز خلال هذه الفترة Yasser Elaraby تجميع بيانات من عدة ملفات اكسيل اسئله واجابات



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





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

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


الكود التالي يقوم بعملية فلترة البيانات و نسخها الى صفحة جديدة باستخدام 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

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





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




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




look/images/icons/i1.gif حل مشكلة فتح الملف اكثر من مرة عند استخدام تقنية ADO
  04-04-2023 04:14 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
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;"";"

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).ClearContents

Sheets("ملخص الارصدة").Range("B7:F" & Sheets("ملخص الارصدة").Cells(Rows.Count, "B").End(xlUp).Row).ClearContents

For ii = 2 To Lr1
SDate = Sheets("الميزانية").Cells(ii, 1)
EDate = Sheets("الميزانية").Cells(ii, 2)
VBalance = Sheets("الميزانية").Cells(ii, 3)
VName = Sheets("الميزانية").Cells(ii, 4)
query = "SELECT SUM(Total) AS TotalSales FROM [المبيعات$] WHERE Date >= #" & SDate & "# AND Date <= #" & EDate & "# AND Name = '" & VName & "'"
rs.Open query, connection, adOpenStatic, adLockOptimistic

If Not IsNull(rs("TotalSales")) Then
    Vresult1 = rs("TotalSales")
Else
    Vresult1 = 0
End If

rs.Close

query = "SELECT SUM(Amount) AS TotalExpenses FROM [المصروفات$] WHERE Date >= #" & SDate & "# AND Date <= #" & EDate & "'"
rs.Open query, connection, adOpenStatic, adLockOptimistic

If Not IsNull(rs("TotalExpenses")) Then
    VResult2 = rs("TotalExpenses")
Else
    VResult2 = 0
End If

rs.Close

Sheets("ملخص الارصدة").Cells(ii + 6, 1) = VName
Sheets("ملخص الارصدة").Cells(ii + 6, 2) = VBalance
Sheets("ملخص الارصدة").Cells(ii + 6, 3) = Vresult1
Sheets("ملخص الارصدة").Cells(ii + 6, 4) = VResult2
Sheets("ملخص الارصدة").Cells(ii + 6, 5) = Vresult1 - VResult2
Next ii

Sheets("ملخص الارصدة").EnableCalculation = True
Application.ScreenUpdating = True

Exit Sub

ErrSub:
MsgBox "An error has occurred: " & Err.Description

End Sub



تم تحرير المشاركة بواسطة :نصر الإيمان بتاريخ:04-04-2023 04:15 مساءً





اضافة رد جديد اضافة موضوع جديد



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
مشكلة في سعر البيع والشراء محمد الخازمي
5 125 محمد الخازمي
مشكلة الدخوا بعد تحيث الموقع صلاح الصغير
1 6 صلاح الصغير
حل مشكلة تهنيج المعادلات ف شيت الاكسل zaki123
1 179 zaki123
مشكلة في تكرار وتصدير البطاقات oilman852
3 184 YasserKhalil
مشكلة التعديل على الصف الأول i7san
1 142 i7san

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









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

الساعة الآن 01:11 AM