تعديل مثال استيراد بيانات من ملف اكسل الي الاكسس برمجيا للاخوة الاعضاء

[mostafaatiya]

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

موجود بالمثال كود يقوم باستيراد بيانات الطلاب من ملف اكسل والحقها بجدول داخل الاكسس

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

ومرفق ملف الاكسل مع المثال 

ولكن حولت التعديل ولكن لم افلح 

وجزاكم الله خيرا 

 

مثال استيراد البيانات.rar

[kanory]

تفضل .......

استبدل الكود بهذا .....

On Error Resume Next
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT [ورقة1$].[اسم الطالب], [ورقة1$].الصف, [ورقة1$].الشعبه, [ورقة1$].الديانه, [ورقة1$].النوع, * FROM [ورقة1$] IN '" & TheFile & "'[Excel 5.0;HDR=NO;IMEX=0;];"
Set qdf = db.CreateQueryDef("kanory", strSQL)

DoCmd.SetWarnings False
DoCmd.RunSQL " SELECT kanory.[اسم الطالب], kanory.الصف, kanory.الشعبه, kanory.الديانه, kanory.النوع INTO Degrees  FROM kanory;"
DoCmd.SetWarnings True
MsgBox "تم"

ملفك ...

 

299.ImportDegrees2022.accdb

تم تعديل يناير 15, 2022 بواسطه kanory

[mostafaatiya]

للاسف الكود لا يعمل

[kanory]

4 ساعات مضت, mostafaatiya said:

للاسف الكود لا يعمل

لا يعمل .... يعني لا يعطي ولا رسالة خطأ ؟؟؟

اعرض لنا فحوى الرسالة حتى نعرف !!!

[عمر ضاحى]

هذا الكود حصلته من الاخوة واساتذتي هنا وهو يعمل جيدا 

    
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 = "CodeGenerator" '"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

 

تم تعديل يناير 16, 2022 بواسطه عمر ضاحى

[mostafaatiya]

7 ساعات مضت, kanory said:

لا يعمل .... يعني لا يعطي ولا رسالة خطأ ؟؟؟

اعرض لنا فحوى الرسالة حتى نعرف !!!

شكرا استاذي الفاضل علي متابعه حضرتك 

حين اقوم باستيراد البيانات من الاكسل لن يقوم باستيراد البيانات ولا يقوم بسحبها وتبقي الجداول فارغة 

5 ساعات مضت, عمر ضاحى said:

هذا الكود حصلته من الاخوة واساتذتي هنا وهو يعمل جيدا 

    
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 = "CodeGenerator" '"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

 

شكرا استاذي الفاضل الكود يعمل بشكل سليم ولكن يقوم بتكرار البيانات حين تشغيل الكود وسحب البيانات

[عمر ضاحى]

2 دقائق مضت, mostafaatiya said:

شكرا استاذي الفاضل علي متابعه حضرتك 

حين اقوم باستيراد البيانات من الاكسل لن يقوم باستيراد البيانات ولا يقوم بسحبها وتبقي الجداول فارغة 

شكرا استاذي الفاضل الكود يعمل بشكل سليم ولكن يقوم بتكرار البيانات حين تشغيل الكود وسحب البيانات

هذا امرها سهل

كل ما عليك اضافة هذه الكود قبل كود الاستيراد 

On Error Resume Next
DoCmd.SetWarnings False
DoCmd.RunSQL ("delete * from NameOfTable")
DoCmd.SetWarnings True

وان شاء الله تتحل المشكله التكرار

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

حتى لا يحدث تكرار

[mostafaatiya]

10 ساعات مضت, عمر ضاحى said:

هذا امرها سهل

كل ما عليك اضافة هذه الكود قبل كود الاستيراد 

On Error Resume Next
DoCmd.SetWarnings False
DoCmd.RunSQL ("delete * from NameOfTable")
DoCmd.SetWarnings True

وان شاء الله تتحل المشكله التكرار

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

حتى لا يحدث تكرار

شكرا لحضرتك تمت الفائدة ربنا يجعله في ميزان حسناتك