بســم الله الـرحمــن الرحيــم
السلام عليكــم ورحمـة الله وبركاتــه
في أحد مشاركات أستاذتي وأختي الكريمة زهرة حفظها الله .. تطرقت لقراءة البيانات من ملف إكسيل وتخزينه في قاعدة البيانات .. وكعادتي ولأستفيد من الدرر الثمينه في أكوادها .. قرأت الأكواد بعنايه وكل أمر أكبس على زر F1 من على لوحة المفاتيح .. للوصول للمساعدة ومحاولة فهم الكود المكتوب .. وبدأت أبحث عن تصدير البيانات إلا أكسيل .. ولكن تبين ووفق قراءتي القديمة أنه لا يمكن تصدير قيمة من أكسيس إلى خلية معينة بحد ذاتها في ملف إكسيل .. إنما تستطيع أن تصدرها فقط من دون تحديد إحداثيات الخلايا .. ليضعها بداية في الخلية A1
وحاولت اليوم أن أبحث أين قرأت هذه المعلومة .. لكي أضعها هنا .. في ملف المساعدة ولكني لم أوفق
عموما فما أريد أن أوصله .. أنني أحيانا أريد أن أستعلم عن معلومة وأضعها في خلية معينة أنا أحددها في الإكسيل .. فبحثت ووجدت طريقة من داخل الإكسيل وهي كالتالي
أنشأت قاعدة بيانات بسيطة وأسميتها DataDb.mdb وفيها جدولين جدول الزبائن Cust بحقلين رقمه وإسمه وجدول المنتجات Product بحقلين رقم الزبون والمنتج وبينهما علاقة واحد لكثير .. وأنشأت إستعلام Qry يستعلم عن إسم الزبون والمنتجات التي إشتراها
وأنشأت ملف إكسيل بإسم ReadDataDb.xls ووضعت في الورقة الأولى تنسيق لتقرير وبجانبه زر أمر يشغل ماكرو وضعت كوده في موديول سترى الكود الخاص به عند الكبس على مفتاحي Alt+F11 معا من لوحة المفاتيح وهو كالتالي
Sub Fill_Cells_With_Data()
Dim MyDB As Database
Dim RC1 As Recordset
Dim CustName As String
Dim RowVar, ColumnVar As Integer
Set MyDB = DBEngine(0).OpenDatabase(Workbooks("ReadDataDb.xls").Path & "\DataDb.mdb")
Set RC1 = MyDB.OpenRecordset("Qry")
'السطر التالي يقوم بنسخ الورقة الأولى وينشأها بعدها لأنها هي الماستر بتنسيقها فلا نريد أن نفقدها ويقوم الكود لاحقا بالتعامل مع النسخة المنشأه بإدخال البيانات وتغيير تنسيقها
Worksheets("Sheet1").Copy After:=Worksheets("Sheet1")
RowVar = 6: ColumnVar = 3: CustName = ""
Do While Not (RC1.EOF)
If CustName = RC1!Name Then
ColumnVar = ColumnVar + 1
If ColumnVar = 8 Then
ColumnVar = 3: RowVar = RowVar + 1
Worksheets(2).Range(Worksheets(2).Cells(RowVar - 1, 2), Worksheets(2).Cells(RowVar, 2)).Merge
End If
Worksheets(2).Cells(RowVar, ColumnVar) = RC1!Product
Else
With Worksheets(2).Range(Worksheets(2).Cells(RowVar, 2), Worksheets(2).Cells(RowVar, 7)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
End With
ColumnVar = 3: RowVar = RowVar + 1
Worksheets(2).Cells(RowVar, 2) = RC1!Name
Worksheets(2).Cells(RowVar, ColumnVar) = RC1!Product
CustName = RC1!Name
End If
RC1.MoveNext
Loop
If CustName <> "" Then
With Worksheets(2).Range(Worksheets(2).Cells(RowVar, 2), Worksheets(2).Cells(RowVar, 7)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
End With
End If
RC1.Close
Set RC1 = Nothing
MyDB.Close
Set MyDB = Nothing
End Subولكن ليعمل الكود السابق بشكل صحيح فيجب إستيراد Microsoft DAO 3.6 Object Library ويتم ذلك وأنت في محرر الأكواد أنقر على قائمة Tools ثم References ستظهر نافذة إبحث عن المكتبة المذكورة وضع بجانبها صح ثم أنقر على Ok
أخيرا .. أعلم أن هذا المثال ليس عمليا .. ولكن المقصد هو الفكرة .. التي ستساعد على إستيراد البيانات التي تحددونها أنتم وتضعونها في الخلية التي تحددونها أنتم
وفي المثال خير مقال .. والحمدلله رب العالمين أولا وآخرا..