اذهب الي المحتوي
أوفيسنا

منع التكرار عند الاستيراد

zhamid

بواسطه zhamid
في قسم الأكسيس Access

 مشاركة

الردود الموصى بها

zhamid

zhamid

قام بنشر
قام بنشر

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

الكود المرفق هو استيراد فايل اكسل الى الاكسس بكبسه من الفورم وشغال مثل الحلاوه اذا كان الجول غير موجود

اما اذا كان الجدول موجود واريد استيراده مره اخرى فانه يضيفه على الجدول ويكون الجدول مكرر

لذا اريد ان عمل الغاء للجدول الموجود بالاكسس قبل كبسه الاستيراد 

مرفق لكم الكود والداتا بيس .........  الرجاء التعديل على المرفق اذا ما فيها ازعاج 

Private Sub Command1_Click()
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 = True

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

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

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

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

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

End Sub
 

Import.rar

رابط هذا التعليق
شارك
رمهان

رمهان

قام بنشر
قام بنشر

انظر التعديل في الجزئية من الكود 

' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
If DCount("[Name]", "MSysObjects", "[Name] = '" & colWorksheets(lngCount) & "'") = 1 Then CurrentDb.TableDefs.Delete colWorksheets(lngCount)
      DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
            strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount

بدون ما اجرب وان شاء الله تمام

بالتوفيق

رابط هذا التعليق
شارك
zhamid

zhamid

قام بنشر
  • الكاتب
قام بنشر

لقد تن التعديل ولكن لم يعمل 

والتعديل كالتالي اذا كان تعديلي صحيح

()Private Sub Command1_Click
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 = True

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

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

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

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 DCount("[Name]", "MSysObjects", "[Name] = '" & colWorksheets(lngCount) & "'") = 1 Then CurrentDb.TableDefs.Delete colWorksheets(lngCount) DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _ strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$" Next lngCount

 

 Delete the collection '
Set colWorksheets = Nothing

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

End Sub
 

رابط هذا التعليق
شارك
رمهان

رمهان

قام بنشر
قام بنشر
في 5/24/2017 at 23:17, أمير2008 said:

ليس  بعد إذن أستاذنا رمهان

 

 

 

Import 02.rar

صح عليك تعديل في مكانه بان حذف السجلات اولى من حذف الجدول

ولكن نبهتني الى ان الجدول وحيد وهو test ويتم اضافة سجلات الشيتات اليه فهنا اعتقد ان وجود حذف السجلات او الجدول داخل التكرار غير مهم بل الافضل خارج التكرار وتنفذ لمرة واحدة

وانا افضل حذف الجدول لو ان حقول الشيتات متغيره والله اعلم

  • Like 1
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر (معدل)

وايه رايكم لو الكود صار هيك
اعتقد حذف الجدول اسهل واسرع من حذف السجلات بداخله فلو عدد السجلات كبير؟!
وبعد اذن استاذ @رمهان ايه الفرق بين حذف الجدول بهذه الطريقة وبالطريقة تبع حضرتك
  

' Import the data from each worksheet into the table

For lngCount = colWorksheets.Count To 1 Step -1
If DCount("[Name]", "MSysObjects", "[Name] = '" & strTable & "'") = 1 Then DoCmd.DeleteObject acTable, "test"
      DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
            strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount

 

تم تعديل بواسطه ابا جودى
رابط هذا التعليق
شارك
رمهان

رمهان

قام بنشر
قام بنشر
6 ساعات مضت, ابا جودى said:

وايه رايكم لو الكود صار هيك
اعتقد حذف الجدول اسهل واسرع من حذف السجلات بداخله فلو عدد السجلات كبير؟!
وبعد اذن استاذ @رمهان ايه الفرق بين حذف الجدول بهذه الطريقة وبالطريقة تبع حضرتك
  


' Import the data from each worksheet into the table

For lngCount = colWorksheets.Count To 1 Step -1
If DCount("[Name]", "MSysObjects", "[Name] = '" & strTable & "'") = 1 Then DoCmd.DeleteObject acTable, "test"
      DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
            strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount

 

هي نفس المهمة ولكن  انت استخدمت بواسطة الاكسس والكائن docmd  انا استخدمت مكتبات dao  والكائن tabledefs 

  • Like 1
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر
1 دقيقه مضت, رمهان said:

هي نفس المهمة ولكن  انت استخدمت بواسطة الاكسس والكائن docmd  انا استخدمت مكتبات dao  والكائن tabledefs 

جزاكم الله خيرا
لكن 
CurrentDb.TableDefs.Delete

هل تحذف كل جداول القاعدة ؟!

ولو لا كيف تحذف هذا الجدول فقط دون غيره

رابط هذا التعليق
شارك
رمهان

رمهان

قام بنشر
قام بنشر
6 دقائق مضت, ابا جودى said:

جزاكم الله خيرا
لكن 
CurrentDb.TableDefs.Delete

هل تحذف كل جداول القاعدة ؟!

ولو لا كيف تحذف هذا الجدول فقط دون غيره

CurrentDb.TableDefs.Delete

بعد هذا الامر تمرر اسم الجدول فهي تحذف جدول واحد 

رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر
21 دقائق مضت, رمهان said:

CurrentDb.TableDefs.Delete

بعد هذا الامر تمرر اسم الجدول فهي تحذف جدول واحد 

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

ده اقتباس مشاركة حضرتك ما يحيرنى اننى لم اجد اسم الجدول 
  

' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
If DCount("[Name]", "MSysObjects", "[Name] = '" & colWorksheets(lngCount) & "'") = 1 Then CurrentDb.TableDefs.Delete colWorksheets(lngCount)
      DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
            strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount

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

انا بصراحة مش قادر افهم واستوعب الموضوع جيدا 

رابط هذا التعليق
شارك
رمهان

رمهان

قام بنشر
قام بنشر
الان, ابا جودى said:

CurrentDb.TableDefs.Delete colWorksheets(lngCount)

في الكود هناك كولشن 

Dim colWorksheets As Collection

ثم تم انشاؤه بواسطة كلمة new  عند الاسناد

Set colWorksheets = New Collection

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

وهنا تم اضافة اسماء الشيتات لها 

For lngCount = 1 To objWorkbook.Worksheets.Count
      colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount

فاصبح لدي قائمة باسماء الشيت . استطيع استخراج كل عنصر بالقائمة من خلال فهرس وجوده (هناك خاصية المتاح key ) تساعد كثيرا ولكن لاتهتم بها الان

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

فعلشان اطلع اول عنصر اعطيه اسم الكولكشن ثم فهرس الصف بين قوسين

فاول عنصر بالكولكشن هو 

colWorksheets(0)

وهو اسم اول شيت

طبعا انا كنت غلطان كنت افكر ان لكل شيت جدول ولكن نبهني الاستاذ اميييير الى ان هناك جدول واحد في الاكسس

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

تحياتي

رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر
27 دقائق مضت, رمهان said:

في الكود هناك كولشن 

Dim colWorksheets As Collection

ثم تم انشاؤه بواسطة كلمة new  عند الاسناد

Set colWorksheets = New Collection

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

وهنا تم اضافة اسماء الشيتات لها 

For lngCount = 1 To objWorkbook.Worksheets.Count
      colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount

فاصبح لدي قائمة باسماء الشيت . استطيع استخراج كل عنصر بالقائمة من خلال فهرس وجوده (هناك خاصية المتاح key ) تساعد كثيرا ولكن لاتهتم بها الان

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

فعلشان اطلع اول عنصر اعطيه اسم الكولكشن ثم فهرس الصف بين قوسين

فاول عنصر بالكولكشن هو 


colWorksheets(0)

وهو اسم اول شيت

طبعا انا كنت غلطان كنت افكر ان لكل شيت جدول ولكن نبهني الاستاذ اميييير الى ان هناك جدول واحد في الاكسس

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

تحياتي

جزااااااااااااااااااااااااكم الله خيرا  اللهم اغفر لكم ولوالديكم وللمسلمين

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع
×
×
  • اضف...

Important Information

  I accept