خطأ في كود الاستيراد

**jjafferr** · أبريل 10, 2020

تفضل 🙂

هذا لملف واحد 🙂

    Dim ImportFileName As String, myField As String
    Dim rst1  As DAO.Recordset, rst2 As DAO.Recordset
    Dim i As Long, j As Long
    
    ImportFileName = Me.txtPath
    CurrentDb.Execute ("Delete * From Table1")
    CurrentDb.Execute ("Delete * From Temp4")

    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "Temp4", ImportFileName, False
    
    Set rst2 = CurrentDb.OpenRecordset("Select * From Table1")
       
    
'there are 2 columns per sheet: F2 and F8
    For j = 2 To 8 Step 6
    
        myField = "F" & j
        
        Set rst1 = CurrentDb.OpenRecordset("Select " & myField & " From Temp4 Where " & myField & " Is Not Null")

        
        rst2.AddNew
        Do Until rst1.EOF
    
            i = i + 1
            
                       
            If i = 1 Then
                rst2![Academic Year] = rst1(myField)
        
            ElseIf i = 2 Then
                rst2![Academic Num] = Mid(rst1(myField), InStrRev(rst1(myField), " ") + 1)
                
            ElseIf i = 3 Then
                rst2![StName] = rst1(myField)
                
            ElseIf i = 4 Then
                rst2![F1] = rst1(myField)
                
            ElseIf i = 5 Then
                rst2![Subjects] = rst1(myField)
                i = 0
                rst2.Update
                rst2.AddNew
            End If
            
            
            rst1.MoveNext
        Loop
        
    
    Next j
    
    rst1.Close: Set rst1 = Nothing
    rst2.Close: Set rst2 = Nothing
    
    MsgBox "تم استيراد البيانات بنجاح"

والى ان انت تعمل التغيير ، مثل برامجك الماضية ، في اختيار ملف او اختيار الكل ، آخذ قيلوله 🙂

جعفر

1206.Posters.zip

**Barna** · أبريل 10, 2020

ملاحظة : أخي @jjafferr نسيت تعدل الكود داخل المثال .... ارجو لك قيلولة مريحة من العناء وتعود بصحة ممتازة .... جزاك الله خيرا

**عفرنس** · أبريل 10, 2020

منذ ساعه, jjafferr said:

تفضل 🙂

هذا لملف واحد 🙂


    Dim ImportFileName As String, myField As String
    Dim rst1  As DAO.Recordset, rst2 As DAO.Recordset
    Dim i As Long, j As Long
    
    ImportFileName = Me.txtPath
    CurrentDb.Execute ("Delete * From Table1")
    CurrentDb.Execute ("Delete * From Temp4")

    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "Temp4", ImportFileName, False
    
    Set rst2 = CurrentDb.OpenRecordset("Select * From Table1")
       
    
'there are 2 columns per sheet: F2 and F8
    For j = 2 To 8 Step 6
    
        myField = "F" & j
        
        Set rst1 = CurrentDb.OpenRecordset("Select " & myField & " From Temp4 Where " & myField & " Is Not Null")

        
        rst2.AddNew
        Do Until rst1.EOF
    
            i = i + 1
            
                       
            If i = 1 Then
                rst2![Academic Year] = rst1(myField)
        
            ElseIf i = 2 Then
                rst2![Academic Num] = Mid(rst1(myField), InStrRev(rst1(myField), " ") + 1)
                
            ElseIf i = 3 Then
                rst2![StName] = rst1(myField)
                
            ElseIf i = 4 Then
                rst2![F1] = rst1(myField)
                
            ElseIf i = 5 Then
                rst2![Subjects] = rst1(myField)
                i = 0
                rst2.Update
                rst2.AddNew
            End If
            
            
            rst1.MoveNext
        Loop
        
    
    Next j
    
    rst1.Close: Set rst1 = Nothing
    rst2.Close: Set rst2 = Nothing
    
    MsgBox "تم استيراد البيانات بنجاح"

والى ان انت تعمل التغيير ، مثل برامجك الماضية ، في اختيار ملف او اختيار الكل ، آخذ قيلوله 🙂

جعفر

1206.Posters.zip 26.15 kB · 1 تنزيلات

قيلولة هنيئة .

أستاذ @jjafferr في هذا الكود يستورد sheet واحد فقط وليس الجميع .

@Barna

**عفرنس** · أبريل 10, 2020

@jjafferr أخبار القيلولة ؟؟

**jjafferr** · أبريل 10, 2020

في الواقع صار لي شوية وقت وانا اشوف كود سابق ، ولكني لازم ارجع الى الكود الاصل اللي انا عملته ، لأنه ما يكون فيه زيادات !!

الصباح رباح ان شاء الله 🙂

جعفر

mohamed orhan · أبريل 10, 2020

اريد رابط شرح كيفيه تجديد تاريخالشهور واضافه شهور السنه الجديده

mohamed orhan · أبريل 10, 2020

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

**عفرنس** · أبريل 10, 2020

34 دقائق مضت, jjafferr said:

في الواقع صار لي شوية وقت وانا اشوف كود سابق ، ولكني لازم ارجع الى الكود الاصل اللي انا عملته ، لأنه ما يكون فيه زيادات !!

الصباح رباح ان شاء الله 🙂

جعفر

بالتوفيق

**عفرنس** · أبريل 11, 2020

@jjafferr

شو أخبار صاحبنا .. إن شاء الله ما يكون عصب عليك😄 .

اقتباس

في الواقع صار لي شوية وقت وانا اشوف كود سابق ، ولكني لازم ارجع الى الكود الاصل اللي انا عملته ، لأنه ما يكون فيه زيادات !!

الصباح رباح ان شاء الله 🙂

جعفر

**jjafferr** · أبريل 11, 2020

السلام عليكم 🙂

هذه الواجهة :

1. لما تفتح لك نافذة الاختيار ، تقدر تختار ملف واحد ، او عن طريق مسك زر Shift او Ctrl تقدر تختار اكثر من ملف ،

2. ستظهر لك اسماء الملفات اللي اخترتها هنا ،

3. هذا الزر اللي يجلب البيانات الى قاعدة البيانات ،

4. و بهذا الزر تختار المجلد ، ومنها يقوم البرنامج بجلب جميع ملفات الاكسل ، ويضع مسار الملفات في #2

image.png.287f733df89bd52b584d4578d928afbb.png

.

وهذه الاكواد ،

1.

Private Sub Browse_Click()

    Dim varFile As Variant

    Me.txtPath = ""
    
    With Application.FileDialog(3)

        .title = "اختار ملف او عدة ملفات"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls ; *.xlsx"
        '.Filters.Add "Excel Files", "*.csv"
        .AllowMultiSelect = True    'False
        .InitialFileName = ""
        
        If .Show = -1 Then
        'Loop through each file selected and add them to the textbox
         For Each varFile In .SelectedItems
            Me.txtPath = varFile & vbCrLf & Me.txtPath
         Next
    
        End If
        
    End With
    
End Sub

.

4.

Private Sub cmd_All_Files_In_Folder_Click()
    
    Dim strPattern As String, myDir As String, varFile As String
    
    
    If MsgBox("هل أنت متأكد من رغبتك في استيراد جميع الملفات" & objName & "؟", vbCritical + vbYesNo + 256, "تأكيد") = vbYes Then

    
        'Important we use msoFileDialogFolderPicker instead of (...)FilePicker
        With Application.FileDialog(4)
 
            'Optional: FileDialog properties
            .title = "Select a folder"
            .InitialFileName = "C:\"
 
            If .Show = -1 Then
                Me.txtPath = ""
                strPattern = "*.xls"
    
                'Loop through each file selected and add them to the textbox
                myDir = .SelectedItems(1) & "\"
                varFile = Dir(myDir & strPattern, vbNormal)
                Do While varFile <> ""
                    Me.txtPath = myDir & varFile & vbCrLf & Me.txtPath
                    varFile = Dir
                Loop

            End If
        
        End With
    
    End If
    
End Sub

.

3.

هذا الكود ينادي بقية الوحدات النمطية ،

Private Sub Command1_Click()


    
    CurrentDb.Execute ("Delete * From Table1")
    CurrentDb.Execute ("Delete * From Temp4")
    
    
    'call for multiple WorkBooks
    Call f_Import_WorkBooks("Temp4")
     
    MsgBox "تم استيراد البيانات بنجاح"
    
End Sub

f_Import_WorkBooks

علشان سهولة استعمال الكود لملفات مثل هذه الملفات ، استيراد جميع الاوراق من الاكسل ، من جميع الملفات في المجلد ،

وما له علاقة بكود استيراد البيانات (هذا الكود الذي ينادي الوحدة النمطية لإستيراد البيانات Call f_Import_to_Table(colWorksheets(lngCount)) ) ،

مع ملاحظة ان هذا الكود لا يتغير بتغير نوع الملفات من موقع النور :

Public Function f_Import_WorkBooks(strTable As String)

    '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
    Dim strPassword As String


'For Multiple files

    Dim x() As String
    x = Split(Me.txtPath, vbCrLf)
    
    For i = LBound(x) To UBound(x) - 1
        strPathFile = x(i)
        
        ' 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

        ' Replace tablename with the real name of the table into which the data are to be imported
        'strTable = "Temp4" '"tablename"
        
        ' Change this next line to True if the first row in EXCEL worksheet has field names
        blnHasFieldNames = False

        ' 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


            'Empty Table
            CurrentDb.Execute ("Delete * From " & strTable)

            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
                strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"


            'save Results to Table
            Call f_Import_to_Table(colWorksheets(lngCount))



Next_lngCount:
        Next lngCount

    'looping for Multiple files
    Next i
    
    
    ' Delete the collection
    Set colWorksheets = Nothing



End Function

.

f_Import_to_Table

وهنا نعمل الكود لإستيراد البيانات من الاكسل ، وهو الكود الذي يحتاج الى تغيير ، كلما اردنا استيراد بيانات مختلفة من موقع النور :

Public Function f_Import_to_Table(Sheet As String)

    Dim myField As String
    Dim rst1  As DAO.Recordset, rst2 As DAO.Recordset
    Dim i As Long, j As Long
        
        
    Set rst2 = CurrentDb.OpenRecordset("Select * From Table1")
    
    
    'يوجد عمودين لكل ورقة :F2 AND F8
    For j = 2 To 8 Step 6
    
        myField = "F" & j
        
        Set rst1 = CurrentDb.OpenRecordset("Select " & myField & " From Temp4 Where " & myField & " Is Not Null")

        
        rst2.AddNew
        Do Until rst1.EOF
    
            i = i + 1
            
                       
            If i = 1 Then
                rst2![Academic Year] = rst1(myField)
                rst2!Sheet = Sheet
        
            ElseIf i = 2 Then
                rst2![Academic Num] = Mid(rst1(myField), InStrRev(rst1(myField), " ") + 1)
                
            ElseIf i = 3 Then
                rst2![StName] = rst1(myField)
                
            ElseIf i = 4 Then
                rst2![F1] = rst1(myField)
                
            ElseIf i = 5 Then
                rst2![Subjects] = rst1(myField)
                i = 0
                rst2.Update
                rst2.AddNew
            End If
            
            
            rst1.MoveNext
        Loop
        
    
    Next j
    
    rst1.Close: Set rst1 = Nothing
    rst2.Close: Set rst2 = Nothing
    
End Function

.

بسبب انني فككت الكود اعلاه ، فالكود يفتح ويغلق Recorsets كثيرا ، مما يؤدي الى بطئ البرنامج (انا اعتبره بطيء ، ومو مثل ما اخوي محمد كان يتمناه بسرعته 🙄 ) ، ولكن اذا صار عندي وقت ان شاء الله انظر فيه مرة اخرى 🙂

جعفر

1206.2.Posters.mdb_accdb.zip

**عفرنس** · أبريل 11, 2020

جزاك الله خيرا أخي @jjafferr

فيه مثل عندنا يقول : ( ما أبطى السيل إلا من كبره ) ومعناه انه ( ما تأخر السيل إلا من كثرته وغزارته )

أنا شاكر لك ومقدر ..

لكن عندي سؤال : ( الشباب ما فزعوا معك ؟؟ ) هههههههه

سأوافيك بالنتائج بإذن الله ..

**Barna** · أبريل 11, 2020

48 دقائق مضت, jjafferr said:

بسبب انني فككت الكود اعلاه ، فالكود يفتح ويغلق Recorsets كثيرا ، مما يؤدي الى بطئ البرنامج (انا اعتبره بطيء ، ومو مثل ما اخوي محمد كان يتمناه بسرعته 🙄 ) ، ولكن اذا صار عندي وقت ان شاء الله انظر فيه مرة اخرى 🙂

جعفر

**أبو إبراهيم الغامدي** · أبريل 11, 2020

السلام عليكم..

أرى أن حواراً ممتعا دار في هذه المشاركة مما أثار رغبتي في المشاركة.. 😀

أرجو أن تجدوا في هذه المشاركة شيئاً جديداً ومميزاً.. 🤩

سوف نتعامل مع مصنف أكسل كقاعدة بيانات ولعمل ذلك نطبق الشفرة التالي

'-- OPEN XLS FILE AS REMOTE DATABASE
Dim XLDB  As DAO.Database
Set XLDB = OpenDatabase( _
CurrentProject.Path & "\CS_SeetNumberLabels2.xlsx", False, False, "EXCEL 12.0;HDR=NO;")

عند فتح مصنف أكسل كقاعدة بيانات سوف تصبح أوراق البيانات كجداول بيانات في أكسس، ولكي نتحقق من ذلك نستخدم الغرض TableDefs لسرد أسماء الجداول (أوراق البيانات)

'-- LOOP THROUGH XLDB TABLES (SHEETS)
For Each TD In XLDB.TableDefs
	TD.Name
Next

:: عند النظر إلى ورقة البيانات في مصنف البانات نجد البيانات محصورة في العمودين (C,I) والبيانات ليست متساوية الطول وبالتالي نحن بحاجة إلى جعل كل عمود جدول بيانات مستقل!

:: يوجد في مكون البيانات Recordset وظيفة اسمه Getrows تقوم بتجميع البيانات كمصفوفة بيانات يحدد طولها المستخدم حسب احتياجة. ولكون البيانات الطالب في ورقة البيانات تتكون من 5 صفوف؛ وبناءُ عليه سوف نقوم بتجميع البيانات على هذا الأساس. لكن يجب أن نقوم بأخذ عدد السجلات في الجدول (ورقة البيانات) والذي هو بالتأكيد من مضاعفات الـ(5).

الوظيفة Getrows تقوم بأخذ المجموع التالية من السجلات عن اطلاقها مرة أخرى وبالتالي نحن بحاجة إلى دوارة بطول السجلات وتقوم بالقفز كل 5 سجلات، بمعنى (20/5).

:: نقوم بعد ذلك بتسجيل البيانات في جدول الطلاب من مصفوفة البيانات التي تعيدها Getrows.

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

الشفرة التالية توضح المبدأ السابق وطريقة نقل البيانات..

'-- LOOP THROUGH XLDB TABLES (SHEETS)
For Each TD In XLDB.TableDefs
'-----------------------------------------------------------------------------------------'
'-- RECORDS FROM COLUMN (C) IN XL SHEET
Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "C:C]WHERE NOT ISNULL(F1)")
'-- COUNT RECORDS
XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
'-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
For I = 1 To RC Step 5
RCROW = XLRS.GetRows(5)
DBRS.AddNew
  DBRS![ACADEMIC YEAR] = RCROW(0, 0)
  DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
  DBRS![STNAME] = RCROW(0, 2)
  DBRS![F1] = RCROW(0, 3)
  DBRS![Sub] = RCROW(0, 4)
DBRS.Update
Next
Set XLRS = Nothing
'--------------------------------------------------------------------------------------'
'-- RECORDS FROM COLUMN (I) IN XL SHEET
Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "I:I]WHERE NOT ISNULL(F1)")
'-- COUNT RECORDS
XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
'-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
For I = 1 To RC Step 5
RCROW = XLRS.GetRows(5)
DBRS.AddNew
  DBRS![ACADEMIC YEAR] = RCROW(0, 0)
  DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
  DBRS![STNAME] = RCROW(0, 2)
  DBRS![F1] = RCROW(0, 3)
  DBRS![Sub] = RCROW(0, 4)
DBRS.Update
Next
Set XLRS = Nothing
Next

إليكم الشفرة كاملة

Option Compare Database
Option Explicit

Sub IMPORT_XLSDB()
   On Error GoTo SUB_CLOSE
   
   '-- OPEN CURRENT DATABASE AS LOCAL DB
   Dim DB As DAO.Database
   Set DB = CurrentDb
   '-- OPEN RS DB TO ADD DATA
   Dim DBRS As DAO.Recordset
   Set DBRS = CurrentDb.OpenRecordset("TABLE")
   
   '-- OPEN XLS FILE AS REMOTE DATABASE
   Dim XLDB  As DAO.Database
   Set XLDB = OpenDatabase( _
   CurrentProject.Path & "\CS_SeetNumberLabels2.xlsx", False, False, "EXCEL 12.0;HDR=NO;")
   '-- OPEN XLS SHEET AS REMOTE RS
   Dim XLRS As DAO.Recordset
   Dim RCROW()
   Dim RC As Long
   Dim I As Integer
   Dim TD As DAO.TableDef
   '-- LOOP THROUGH XLDB TABLES (SHEETS)
   For Each TD In XLDB.TableDefs
   '-----------------------------------------------------------------------------------------'
      '-- RECORDS FROM COLUMN (C) IN XL SHEET
      Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "C:C]WHERE NOT ISNULL(F1)")
      '-- COUNT RECORDS
      XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
      '-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
      For I = 1 To RC Step 5
         RCROW = XLRS.GetRows(5)
         DBRS.AddNew
            DBRS![ACADEMIC YEAR] = RCROW(0, 0)
            DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
            DBRS![STNAME] = RCROW(0, 2)
            DBRS![F1] = RCROW(0, 3)
            DBRS![Sub] = RCROW(0, 4)
         DBRS.Update
      Next
      Set XLRS = Nothing
      '--------------------------------------------------------------------------------------'
      '-- RECORDS FROM COLUMN (I) IN XL SHEET
      Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "I:I]WHERE NOT ISNULL(F1)")
      '-- COUNT RECORDS
      XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
      '-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
      For I = 1 To RC Step 5
         RCROW = XLRS.GetRows(5)
         DBRS.AddNew
            DBRS![ACADEMIC YEAR] = RCROW(0, 0)
            DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
            DBRS![STNAME] = RCROW(0, 2)
            DBRS![F1] = RCROW(0, 3)
            DBRS![Sub] = RCROW(0, 4)
         DBRS.Update
      Next
      Set XLRS = Nothing
   Next
SUB_CLOSE:
   '-- COLOSE XLDB AND XLRS
   Set XLRS = Nothing
'   XLDB.Close
   Set XLDB = Nothing
   '------------------------'
   '-- CLOSE DB AND DBRS
   Set DBRS = Nothing
   XLDB.Close
   Set XLDB = Nothing
End Sub

وهذه هي المفرفقات التى تتضمن المثال...

CS_SeetNumberLabels2.xlsx Posters.accdb

**Barna** · أبريل 11, 2020

في ٩‏/٤‏/٢٠٢٠ at 22:34, jjafferr said:

شو السالفة !!

اشوف متفقين عليّ 😁

لا تكونوا متراهنين ، وتنتظرون تشوفون من بيفوز !!

انا آسف ، ما ممكن اتابع ، إلا بأن اشوف ملف التلاميذ كلهم ، وإلا فمافيه فائدة 🙂

جعفر

في ٩‏/٤‏/٢٠٢٠ at 23:01, Barna said:

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

أولا الشكر للاستاذ الكبير @jjafferr و الاستاذ الكبير @أبو إبراهيم الغامدي على المشاركة

ثانيا وبكل فخر أقول لكما نجحنا في استفزاز الكبار

ثالثا استفدت انا شخصيا من مشاكتكم القيمة والاسلوب المتبع في صياغة بعض الاكواد

شكرا ..... شكرا ...... لكما .... بارك الله فيكما وفي وقتيكما :signthankspin:

**عفرنس** · أبريل 11, 2020

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

أولا الشكر للاستاذ الكبير @jjafferr و الاستاذ الكبير @أبو إبراهيم الغامدي على المشاركة

ثانيا وبكل فخر أقول لكما نجحنا في استفزاز الكبار

ثالثا استفدت انا شخصيا من مشاكتكم القيمة والاسلوب المتبع في صياغة بعض الاكواد

شكرا ..... شكرا ...... لكما .... بارك الله فيكما وفي وقتيكما

شكر الله لكم جميعا ..

ما أجمل استفزاز العمالقة الكبار ..

**عفرنس** · أبريل 11, 2020

28 دقائق مضت, أبو إبراهيم الغامدي said:
السلام عليكم..

أرى أن حواراً ممتعا دار في هذه المشاركة مما أثار رغبتي في المشاركة.. 😀

أرجو أن تجدوا في هذه المشاركة شيئاً جديداً ومميزاً.. 🤩

سوف نتعامل مع مصنف أكسل كقاعدة بيانات ولعمل ذلك نطبق الشفرة التالي
'-- OPEN XLS FILE AS REMOTE DATABASE
Dim XLDB  As DAO.Database
Set XLDB = OpenDatabase( _
CurrentProject.Path & "\CS_SeetNumberLabels2.xlsx", False, False, "EXCEL 12.0;HDR=NO;")
عند فتح مصنف أكسل كقاعدة بيانات سوف تصبح أوراق البيانات كجداول بيانات في أكسس، ولكي نتحقق من ذلك نستخدم الغرض TableDefs لسرد أسماء الجداول (أوراق البيانات)
'-- LOOP THROUGH XLDB TABLES (SHEETS)
For Each TD In XLDB.TableDefs
	TD.Name
Next
:: عند النظر إلى ورقة البيانات في مصنف البانات نجد البيانات محصورة في العمودين (C,I) والبيانات ليست متساوية الطول وبالتالي نحن بحاجة إلى جعل كل عمود جدول بيانات مستقل!

:: يوجد في مكون البيانات Recordset وظيفة اسمه Getrows تقوم بتجميع البيانات كمصفوفة بيانات يحدد طولها المستخدم حسب احتياجة. ولكون البيانات الطالب في ورقة البيانات تتكون من 5 صفوف؛ وبناءُ عليه سوف نقوم بتجميع البيانات على هذا الأساس. لكن يجب أن نقوم بأخذ عدد السجلات في الجدول (ورقة البيانات) والذي هو بالتأكيد من مضاعفات الـ(5).

الوظيفة Getrows تقوم بأخذ المجموع التالية من السجلات عن اطلاقها مرة أخرى وبالتالي نحن بحاجة إلى دوارة بطول السجلات وتقوم بالقفز كل 5 سجلات، بمعنى (20/5).

:: نقوم بعد ذلك بتسجيل البيانات في جدول الطلاب من مصفوفة البيانات التي تعيدها Getrows.

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

الشفرة التالية توضح المبدأ السابق وطريقة نقل البيانات..
'-- LOOP THROUGH XLDB TABLES (SHEETS)
For Each TD In XLDB.TableDefs
'-----------------------------------------------------------------------------------------'
'-- RECORDS FROM COLUMN (C) IN XL SHEET
Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "C:C]WHERE NOT ISNULL(F1)")
'-- COUNT RECORDS
XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
'-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
For I = 1 To RC Step 5
RCROW = XLRS.GetRows(5)
DBRS.AddNew
  DBRS![ACADEMIC YEAR] = RCROW(0, 0)
  DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
  DBRS![STNAME] = RCROW(0, 2)
  DBRS![F1] = RCROW(0, 3)
  DBRS![Sub] = RCROW(0, 4)
DBRS.Update
Next
Set XLRS = Nothing
'--------------------------------------------------------------------------------------'
'-- RECORDS FROM COLUMN (I) IN XL SHEET
Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "I:I]WHERE NOT ISNULL(F1)")
'-- COUNT RECORDS
XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
'-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
For I = 1 To RC Step 5
RCROW = XLRS.GetRows(5)
DBRS.AddNew
  DBRS![ACADEMIC YEAR] = RCROW(0, 0)
  DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
  DBRS![STNAME] = RCROW(0, 2)
  DBRS![F1] = RCROW(0, 3)
  DBRS![Sub] = RCROW(0, 4)
DBRS.Update
Next
Set XLRS = Nothing
Next
إليكم الشفرة كاملة
Option Compare Database
Option Explicit

Sub IMPORT_XLSDB()
   On Error GoTo SUB_CLOSE
   
   '-- OPEN CURRENT DATABASE AS LOCAL DB
   Dim DB As DAO.Database
   Set DB = CurrentDb
   '-- OPEN RS DB TO ADD DATA
   Dim DBRS As DAO.Recordset
   Set DBRS = CurrentDb.OpenRecordset("TABLE")
   
   '-- OPEN XLS FILE AS REMOTE DATABASE
   Dim XLDB  As DAO.Database
   Set XLDB = OpenDatabase( _
   CurrentProject.Path & "\CS_SeetNumberLabels2.xlsx", False, False, "EXCEL 12.0;HDR=NO;")
   '-- OPEN XLS SHEET AS REMOTE RS
   Dim XLRS As DAO.Recordset
   Dim RCROW()
   Dim RC As Long
   Dim I As Integer
   Dim TD As DAO.TableDef
   '-- LOOP THROUGH XLDB TABLES (SHEETS)
   For Each TD In XLDB.TableDefs
   '-----------------------------------------------------------------------------------------'
      '-- RECORDS FROM COLUMN (C) IN XL SHEET
      Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "C:C]WHERE NOT ISNULL(F1)")
      '-- COUNT RECORDS
      XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
      '-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
      For I = 1 To RC Step 5
         RCROW = XLRS.GetRows(5)
         DBRS.AddNew
            DBRS![ACADEMIC YEAR] = RCROW(0, 0)
            DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
            DBRS![STNAME] = RCROW(0, 2)
            DBRS![F1] = RCROW(0, 3)
            DBRS![Sub] = RCROW(0, 4)
         DBRS.Update
      Next
      Set XLRS = Nothing
      '--------------------------------------------------------------------------------------'
      '-- RECORDS FROM COLUMN (I) IN XL SHEET
      Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "I:I]WHERE NOT ISNULL(F1)")
      '-- COUNT RECORDS
      XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
      '-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
      For I = 1 To RC Step 5
         RCROW = XLRS.GetRows(5)
         DBRS.AddNew
            DBRS![ACADEMIC YEAR] = RCROW(0, 0)
            DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
            DBRS![STNAME] = RCROW(0, 2)
            DBRS![F1] = RCROW(0, 3)
            DBRS![Sub] = RCROW(0, 4)
         DBRS.Update
      Next
      Set XLRS = Nothing
   Next
SUB_CLOSE:
   '-- COLOSE XLDB AND XLRS
   Set XLRS = Nothing
'   XLDB.Close
   Set XLDB = Nothing
   '------------------------'
   '-- CLOSE DB AND DBRS
   Set DBRS = Nothing
   XLDB.Close
   Set XLDB = Nothing
End Sub
وهذه هي المفرفقات التى تتضمن المثال...

CS_SeetNumberLabels2.xlsx 85.5 kB · 3 تنزيلات Posters.accdb 480 kB · 2 تنزيلات

أخي إبراهيم

جزيت خيرا

جربت المرفق مع تعديلاتك

يعطيني هذا الخطأ

**أبو إبراهيم الغامدي** · أبريل 11, 2020

27 دقائق مضت, فايز.. said:

أخي إبراهيم

جزيت خيرا

جربت المرفق مع تعديلاتك

يعطيني هذا الخطأ

أعتذر عن هذا الخطأ غير المقصود..

إليك التصحيح..

Posters.accdb

**jjafferr** · أبريل 11, 2020

49 دقائق مضت, أبو إبراهيم الغامدي said:

أرجو أن تجدوا في هذه المشاركة شيئاً جديداً ومميزاً.. 🤩

سوف نتعامل مع مصنف أكسل كقاعدة بيانات

احسنت واجدت اخوي ابو ابراهيم ، وسلمت يداك 🙂

هي الفكرة جميلة ، وأجمل من التنفيذ ، وبالفكرة والتنفيذ تكون ولا أجمل 🙂

مرة اخرى ، بالفعل مبدع ، وشكرا جزيلا على الاثراء بالمشاركة 🙂

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

وبكل فخر أقول لكما نجحنا في استفزاز الكبار

35 دقائق مضت, فايز.. said:

ما أجمل استفزاز العمالقة الكبار ..

الحمدلله ، طلعنا بوجوه بيضاء 🙂

1 ساعه مضت, فايز.. said:

لكن عندي سؤال : ( الشباب ما فزعوا معك ؟؟ )

يعني تعتقد الكود اللي مقطع بهذه الطريقة الغريبة ، جاي لحاله :biggrin:

جعفر

**عفرنس** · أبريل 11, 2020

اقتباس

يعني تعتقد الكود اللي مقطع بهذه الطريقة الغريبة ، جاي لحاله

ههههههههههههههههههه

ما ودك رسل لي اثنين من الشباب ذولي يدرسوني ؟؟

تم تعديل أبريل 11, 2020 بواسطه فايز..

**أبو إبراهيم الغامدي** · أبريل 11, 2020

3 دقائق مضت, jjafferr said:

الحمدلله ، طلعنا بوجوه بيضاء 🙂

وأياديك بيضاء أيضاً أستاذ جعفر.. لا عدمناك 🤑

**عفرنس** · أبريل 11, 2020

اقتباس

أعتذر عن هذا الخطأ غير المقصود..

إليك التصحيح..

أخي عبد العزيز @أبو إبراهيم الغامدي

شكر الله لك .. وجمل حالك ..

سأحتفظ بكلا العملين ( ما تفضلت به وما تفضل به الأستاذ جعفر )

لكن لدي سؤال صغير ( فيما لو أردت استيراد أكثر من ملف دفعة واحدة هل هذا ممكن ؟؟ ) في الكود الحالي ؟؟ لأني جربت فلم ينجح .

**أبو إبراهيم الغامدي** · أبريل 12, 2020

4 ساعات مضت, فايز.. said:

لكن لدي سؤال صغير ( فيما لو أردت استيراد أكثر من ملف دفعة واحدة هل هذا ممكن ؟؟ ) في الكود الحالي ؟؟ لأني جربت فلم ينجح .

نعم عزيزي..

إليك هذا الحل السريع

Posters.accdb

**أبوبسمله** · أبريل 12, 2020

اما انا فاقول لكم اخوانى واساتذتى @Barna @jjafferr @أبو إبراهيم الغامدي :fff: :signthankspin:

جزاكم الله خيرا ونفع بكم الاسلام والمسلمين ورزقكم الفردوس الاعلى وانا يظلنا يوم لا ظل الا ظله

بارك الله فيكم جميعا وفيك اخى فايز :fff:

تمنياتى لكم وللجميع بالتوفيق ان شاء الله

**عفرنس** · أبريل 12, 2020

11 ساعات مضت, أبو إبراهيم الغامدي said:

نعم عزيزي..

إليك هذا الحل السريع

Posters.accdb 488 kB · 4 تنزيلات

أخي عبدالعزيز @أبو إبراهيم الغامدي

هكذا تظهر الرسالة

**Barna** · أبريل 12, 2020

3 دقائق مضت, فايز.. said:

أخي عبدالعزيز @أبو إبراهيم الغامدي

هكذا تظهر الرسالة

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

فالاخ @أبو إبراهيم برمج استيرادها على اساس الحقل C وليس D

تسجيل الدخول

خطأ في كود الاستيراد

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

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

jjafferr

أبو إبراهيم الغامدي

jjafferr

Posted Images

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information