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

[jandbi]

السلام عليكم ورحمة الله وبركاته

بالمرفقات ملف مضغوط يحتوي على ..

- ملف اكسل ( يحتوي على 3 صفحات )
- قاعدة بيانات اكسس ( تحتوي على جدول ونموذج )

جهزت النموذج في الاكسس بحيث انه يحتوي على مربع لاستعراض ملف الاكسل اللي راح استورد بياناته ..

اللي احتاجه ..
زر الاستيراد .. بحيث انه يقوم باستيراد الدرجات من كل صفحة ( كل صفحة لطالب واحد ) ويقوم بوضعها في جدول الاكسس ( جدول واحد فقط )

 

هل من خبير يساعدنا ؟ :)

 

استيراد الدرجات.rar

[moham_q]

اخي العزيز ... يمكنك ذلك من خلال انشاء ماكرو وتقوم باختيار الحقول المطلوبة كما في الصورة المرفقة وتقوم بعدها ب انشاء زر كوماند يقوم بتنفيذ الماكرو الذي انشئته ... تحياتي

[jandbi]

الله يعطيك العافية ..

نفذت المطلوب وظهرت لي رسالة ..

 

تم تعديل نوفمبر 21, 2015 بواسطه jandbi

[jandbi]

نسيت ان اضيف ملاحظة على ملف الاكسل ..

عناوين البيانات في الصفحات مكانها ثابت لا يتغير ..

مثلا درجة القران الكريم عنوانها في صفحة الاكسل B2 في Sheet1 وفي كل الصفحات الباقية ..

وكذلك بقية البيانات من رقم الهوية والمواد الاخرى

[moham_q]

اخي العزيز هذه الطريقة تقوم باستيراد ملفات الاكسل االتي تختارها الى جدول اكسيس ولا يمكن لصقها بجدول اخر موجود لديك في نفس قاعدة البيانات ... اولا قم بعملية الاستيراد ثم بعدها قم بعملية الالحاق من خلال تكوين استعلام الحاق ويجب توحيد ستركجر الجداول قبل تنفيذ الالحاق ... تحياتي

[jandbi]

جربت الطريقة مرة اخرى ..

للاسف لا تقوم بالمطلوب حيث انها تستورد اول صفحة فقط وبقية الصفحات لا

كما اني لا احتاج الا خلايا محددة فقط ( درجة المادة ) وليس كل البيانات من ورقة الاكسل

[jandbi]

ما فيه احد يقدر يساعدنا ؟ :(

[jjafferr]

السلام عليكم 

في 11/22/2015, 1:41:01, mohammed_hq said:

اخي العزيز هذه الطريقة (TransferSpreadsheet) تقوم باستيراد ملفات الاكسل االتي تختارها الى جدول اكسيس

 

في 11/22/2015, 12:02:51, jandbi said:

للاسف لا تقوم بالمطلوب حيث انها تستورد اول صفحة فقط وبقية الصفحات لا

.

هذا صحيح ، ولكن في نهاية الدالة تستطيع تختار النطاق Range او الورقة/sheet ، فعليه يمكنك ان تعيد الامر اكثر من مرة ، كل مرة لورقة اكسل اخرى (لاحظ اسماء الـSheet):

    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet1$"
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet2$"
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet3$"

.

ولكن هذا الامر يتطلب منا ان نعرف عدد الاوراق/Sheets ، واسمائها 

------------------------------------------------------------------------------------------------------------------------

والآن لشرح ما عملته انا:

1. عملت جدول اسمه tbl_Sheets ، لإدخال جميع المعلومات في جميع الاوراق/Sheets:

.

وعن طريق الكود (الكود سيكون في نهاية الموضوع) ، يأخذ البيانات ، فيصبح:

.

ثم يأتي الكود مرة اخرى ، فيملئ حقل ID لكل علامة:

.

ثم عملت استعلام جدولي CrossTab ، والذي به نستطيع ان نجعل بيانات احد الاعمدة عبارة عن اعمدة متفرقة ، يعني الحقل F1 ، اردنا ان نجعل كل مادة عبارة عن عمود مستقل):

.

وهذه نتائجه:

.

والان الى عمل استعلام آخر ، لجمع كل هذه السجلات:

.

فاصبحت:

.

الآن وقد اصبحت البيانات جاهزة لإلحاقها بالجدول النهائي Degrees ، نعمل استعلام الحاقي:

.

والكود الذي يقوم بكل العمل:

Private Sub ImportData_Click()

    'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet1$"
    'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet2$"
    'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet3$"
    
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile As String, strTable As String
Dim strPassword As String

' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
      Set objExcel = CreateObject("Excel.Application")
      blnEXCEL = True
End If
Err.Clear
On Error GoTo 0

' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False

' Replace C:\Filename.xls with the actual path and filename
strPathFile = Me.txtPath    ' "C:\Filename.xls"

' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tbl_Sheets" '"tablename"

' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = vbNullString  '"passwordtext"

blnReadOnly = True ' open EXCEL file in read-only mode

' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _
      strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
      colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount

' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing

' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
      DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
            strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"

Next lngCount

' Delete the collection
Set colWorksheets = Nothing


'---------------------------------
'   importing is finished

    'now organize the table, by adding the ID to all the group
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Select * From tbl_Sheets")
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    For i = 1 To RC
        
        If rst!F1 = "رقم الهوية" Then   'And Len(rst!ID & "") = 0 Then
            myID = rst!F2
            rst.Edit
                rst!ID = myID
            rst.Update
        Else
            rst.Edit
                rst!ID = myID
            rst.Update
        End If
        
        rst.MoveNext
    Next i

    rst.Close: Set rst = Nothing

    'append the data
    DoCmd.SetWarnings False
    DoCmd.OpenQuery "qry_Append_Sheets"
    DoCmd.SetWarnings True
    
    MsgBox "Done"

' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile

End Sub

.

.

ولكن ، يجب عليك ان تحذف بيانات الجداول Degree و tbl_Sheets قبل ان تقوم بأي عمل 

 

 

جعفر

 

 

 

275.ImportDegrees.accdb.zip

[اسلام سيد]

بصراحه طريقة عرض الاجابات تفتح النفس

ربنا يبارك فيكم

اللهم وفق الجميع الى ما تحبه وترضه

 

[jandbi]

الاستاذ الكبير جعفر ..

للامانة كنت في انتظارك :) ..

إجابة على سؤالك عن عدد الصفحات .. قد يصل عدد sheet الى اكثر من 1000 :/ << واعتقد ان هالشيء صعب يدوياً :(

سأقوم بتجربة ما كتبته بإذن الله .. وأعود لك

[jjafferr]

حيا الله من يانا 

 

وهذه طريقة اخرى ، اذا كانت ملفاتك تنزلها من موقع النور ، التابع لوزارة التعليم في المملكة العربية السعودية 

 

 

جعفر

275.1.ImportDegrees.accdb.zip

 

تم تعديل نوفمبر 24, 2015 بواسطه jjafferr

[jjafferr]

السلام عليكم 

 

لاحظت تكرار بعض البيانات ، فاليك النسخة المعدلة 

275.1.ImportDegrees.accdb.zip

[Barna]

السلام عليكم ورحمة الله وبركاته

اسمح لي أخي jjafferr  بعد اذنك ......

هذه محاولة طالب من طلاب هذا المنتدى وغيره من المنتديات 

في الملف المرفق طريقو كود لأستيراد جميع اوراق ملف الاكسل مهما كان عددها بشرط تتطابق تنسيق الاوراق ............. أشكر لك سعت صدرك ..... 

Ba-degrees.rar

[jjafferr]

15 دقائق مضت, Barna said:

اسمح لي أخي jjafferr  بعد اذنك

حياك الله أخوي 

[Barna]

 اشكرك اخي ولكن مارايك بالطريقة ...... 

[jandbi]

الاستاذ الكريم جعفر ..

يبدو ان اخر ملف ارفقته هو نفسه اللي انا وضعته اول الموضوع :)

على العموم ملاحظتي اللي ودي تعدلها على البرنامج :

- منع تكرار البيانات ( يأخذ رقم الهوية فقط ) مثل ما ذكرتها لك في الخاص :)

- يوجد مشكلة في خانة RankA و RankB ( احتاج تكون البيانات بالعكس فيها )

- ارغب بإضافة خاصية : عند استيراد ملف اكسل جديد لا يقوم بحذف البيانات القديمة في الجدول وإنما يضيف البيانات الجديدة عليها ( وعند تشابه ID يقوم بحذف البيانات القديمة والإبقاء على الجديدة )

[jjafferr]

حيا الله الاستاذ 

 

عفوا على الخطأ ، رجاء جرب هذا الملف ثم نتكلم عن الباقي 

 

 

جعفر

275.1.ImportDegrees.accdb.zip

[jandbi]

الله يعطيك العافية .. يعمل بشكل سليم

بالنسبة للملاحظة : - يوجد مشكلة في خانة RankA و RankB ( احتاج تكون البيانات بالعكس فيها )  ..

قمت بحلها عن طريق تعديل استعلام الالحاق وغيرت مكان الالحاق بين الحقول :)

 

بقي الملاحظة الاخيرة :

- ارغب بإضافة خاصية : عند استيراد ملف اكسل جديد لا يقوم بحذف البيانات القديمة في الجدول وإنما يضيف البيانات الجديدة عليها ( وعند تشابه ID يقوم بحذف البيانات القديمة والإبقاء على الجديدة )

[jjafferr]

27 دقائق مضت, jandbi said:

قمت بحلها عن طريق تعديل استعلام الالحاق وغيرت مكان الالحاق بين الحقول :)

يا فنان انت ، سهلت علي الموضوع 

كنت اريد اقول لك تعملها ، لكني استحيت  ، ولأن عندنا مثل يقول: اكلت الثور وما باقي غير الذيل ، يعني ما نقدر ناكله 

 

35 دقائق مضت, jandbi said:

- ارغب بإضافة خاصية : عند استيراد ملف اكسل جديد لا يقوم بحذف البيانات القديمة في الجدول وإنما يضيف البيانات الجديدة عليها ( وعند تشابه ID يقوم بحذف البيانات القديمة والإبقاء على الجديدة )

ليش؟؟

مو انا سحبت لك بيانات اكثر من المطلوبة ، والسبب هو علشان تقدر تستخدم هذه الحقول الزائدة في عملية الفرز والتصفية (مثل الفصل والسنة الدراسية) ، والتي تستطيع لاحقا ان تتبع عمل الطالب لعدة سنوات ، مثلا 

ايش رايك ، موافق على هالكلام ، وإلا حاب تجرب طعم الذيل 

 

جعفر

[jjafferr]

5 ساعات مضت, Barna said:

 اشكرك اخي ولكن مارايك بالطريقة ...... 

انا اعتذر منك أخوي على عدم تجربة المرفق حاليا ، فانا بين مجموعة من الاسئلة واحاول اوفق وقتي في حلها ، وان شاء الله اشوف مرفقك واخبرك رأيي فيه 

والعذر عند كرام الناس مقبول 

 

جعفر

[jandbi]

هههههههه حلوة طعم الذيل

انت ما فهمت قصدي .. انا مثلاً سحبت اول ملف اكسل .. لو بغيت اسحب ملف اكسل ثاني ( البرنامج حاليا ) راح يمسح البيانات الموجودة بجدول Degree ويضيف الجديدة

انا ابغاه يخلي القديم ويضيف الجديد ( ولو تشابه حقل ID وحقل ال Class وحقل Year_H وحقل Year_G ) يقوم بحذف البيانات القديمة :)

[jjafferr]

تفضل 

275.2.ImportDegrees.accdb.zip

[jandbi]

الله يكتب لك الاجر ويرزقك من واسع علمه وفضله ورزقه ..

الشكر قليل في حقك اخوي جعفر ..

[jjafferr]

حياك الله أستاذ 

بس شوي شوي على اولادنا الطلبه 

 

 

جعفر

[jjafferr]

السلام عليكم أستاذ 

 

الظاهر ان موقع النور فيه نوع آخر من ملفات الاكسل ، والذي بشمل علامات لغتي الخالدة فقط ،

عليه ، اليك طريقة استيرادهم ، بنفس الطريقة القديمة ، ولكن لجدول خاص به 

 

النموذج  يطلب منك اختيار نوع ملف الاكسل ، والباقي يقوم الكود به 

.

وهذا كود الاستيراد (طبعا هناك مجموعة من الاستعلامات في البرنامج):

Option Compare Database

Private Sub Browse_Click()
Dim fpath As Variant
With Application.FileDialog(3)
.Title = "Choose File"
.Filters.Clear
.Filters.Add "Excel Files", "*.xls ; *.xlsx"
'.Filters.Add "Excel Files", "*.csv"
.AllowMultiSelect = False
.InitialFileName = ""
If .Show = -1 Then
Me.txtPath = .SelectedItems(1)
End If
End With
Exit Sub
End Sub

Private Sub ImportData_Click()

    If Me.frm_Which_Type = 0 Then
        'the user didn't choose anything, let him know
        MsgBox "رجاء اختيار اي نوع من الملفات تريد ان تستورد" & vbCrLf & "Please Select an option"
        Exit Sub
        
    ElseIf Len(Me.txtPath & "") = 0 Then
        'don't leave the path empty
        MsgBox "رجاء اختيار ملف الاكسل" & vbCrLf & "Please select an Excel file"
        Exit Sub
    End If
        

'1
    'Empty Table Degrees and tbl_Sheets
'   CurrentDb.Execute ("Delete * From Degrees")
'   CurrentDb.Execute ("Delete * From tbl_Sheets")
    
'2
    'import Sheets
    Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
    Dim lngCount As Long
    Dim objExcel As Object, objWorkbook As Object
    Dim colWorksheets As Collection
    Dim strPathFile As String, strTable As String
    Dim strPassword As String

    ' Establish an EXCEL application object
    On Error Resume Next
    Set objExcel = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set objExcel = CreateObject("Excel.Application")
        blnEXCEL = True
    End If
    Err.Clear
    On Error GoTo 0

    ' Change this next line to True if the first row in EXCEL worksheet
    ' has field names
    blnHasFieldNames = False

    ' Replace C:\Filename.xls with the actual path and filename
    strPathFile = Me.txtPath    ' "C:\Filename.xls"

    ' Replace tablename with the real name of the table into which
    ' the data are to be imported
    strTable = "tbl_Sheets" '"tablename"

    ' Replace passwordtext with the real password;
    ' if there is no password, replace it with vbNullString constant
    ' (e.g., strPassword = vbNullString)
    strPassword = vbNullString  '"passwordtext"

    blnReadOnly = True ' open EXCEL file in read-only mode

    ' Open the EXCEL file and read the worksheet names into a collection
    Set colWorksheets = New Collection
    Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , strPassword)
    For lngCount = 1 To objWorkbook.Worksheets.Count
        colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
    Next lngCount

    ' Close the EXCEL file without saving the file, and clean up the EXCEL objects
    objWorkbook.Close False
    Set objWorkbook = Nothing
    If blnEXCEL = True Then objExcel.Quit
    Set objExcel = Nothing

    ' Import the data from each worksheet into the table
    For lngCount = colWorksheets.Count To 1 Step -1
        'If lngCount <> 9 And lngCount <> 8 Then GoTo Next_lngCount

'3
        'Empty Table Degrees and tbl_Sheets
        'j'CurrentDb.Execute ("Delete * From tbl_Sheets")
        CurrentDb.Execute ("Delete * From " & strTable)
        
'--
'4
        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
            strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
'--
'5

        If Me.frm_Which_Type = 2 Then
            'the user choose Loqati ONLY
            add_Loqati = "_Loqati"
        Else
            add_Loqati = ""
        End If
        
        my_qry_Select = "qry_Select" & add_Loqati
        my_qry_Delete_Duplicate = "qry_Delete_Duplicate" & add_Loqati
        my_qry_Append = "qry_Append" & add_Loqati
        my_qry_Update_Sheet = "qry_Update_Sheet" & add_Loqati
        
        'Delete Duplicate
        Dim rstQ As DAO.Recordset
        mySQL = "Select * From " & my_qry_Select
        Set rstQ = CurrentDb.OpenRecordset(mySQL)
        [F16] = rstQ![F16]
        [F8] = rstQ![F8]
        [F17] = rstQ![F17]
        [F29] = rstQ![F29]
        [F24] = rstQ![F24]
        rstQ.Close: Set rstQ = Nothing
        
        DoCmd.SetWarnings False
        DoCmd.OpenQuery my_qry_Delete_Duplicate
        DoCmd.SetWarnings True
    
'-------------
'6
        'append the data
        DoCmd.SetWarnings False
        DoCmd.OpenQuery my_qry_Append
        DoCmd.SetWarnings True
'-------------

        DoEvents
        Me.iSheet = colWorksheets.Count
        Me.iSheet2 = lngCount
    
'-------------
'7
        'append the data
        DoCmd.SetWarnings False
        DoCmd.OpenQuery my_qry_Update_Sheet
        DoCmd.SetWarnings True
'-------------
    
    
'8
        'empty tbl_Sheets
        CurrentDb.Execute ("Delete * From " & strTable)

Next_lngCount:
    Next lngCount

    ' Delete the collection
    Set colWorksheets = Nothing


    MsgBox "Done"

' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile

End Sub

 

جعفر

275.3.ImportDegrees.accdb.zip