إضافة كود في برنامج MARK

[عفرنس]

لدي هذا البرنامج وأريد إضافة الكود التالي فيه وتغيير ما يلزم . 

تنبيه " لا أريد إضافة الحقول التالية في جدول   " A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 "MARK  

Public Function f_import_from_excel(w_Files As String) As String

    'w_Files = Which Files to use:
    'All : all from the current directory
    'otherwise , from a selected directory
    
    CurrentDb.Execute ("Delete * From mark")
    CurrentDb.Execute ("Delete * From Temp3")

    Forms!Mark!barna = Forms!Mark!barna & vbCr & "انتظر من فضلك "

    Dim strPathFile As String, strFile As String, strPassword, strWorksheet, strTable, strSQL, strPath As String
    Dim blnHasFieldNames, blnEXCEL, blnReadOnly As Boolean
    Dim lngCount As Long
    Dim objExcel As Object, objWorkbook As Object
    Dim colWorksheets As Collection

    blnHasFieldNames = False

'w_Files
        If w_Files = "All" Then
            strPath = Application.CurrentProject.Path & "\"
        Else
            strPath = Me.txtPath
        End If

    strWorksheet = "StudentsData"
    strTable = "Temp3"

'w_Files
        If w_Files = "All" Then
            strFile = Dir(strPath & "*.xlsx")
        Else
            strFile = Dir(strPath)
        End If
        
    Do While Len(strFile) > 0
        strPathFile = strPath & strFile

        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
        blnHasFieldNames = False

'w_Files
            If w_Files = "All" Then
                strPathFile = Application.CurrentProject.Path & "\" & strFile  ' "C:\Filename.xls"
            Else
                strPathFile = Me.txtPath
            End If
            
        strTable = "Temp3" '"tablename"

        strPassword = vbNullString  '"passwordtext"
        blnReadOnly = True ' open EXCEL file in read-only mode

        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

        objWorkbook.Close False
        Set objWorkbook = Nothing
        If blnEXCEL = True Then objExcel.Quit
        Set objExcel = Nothing

        For lngCount = colWorksheets.Count To 1 Step -1

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

            DoEvents
    
            Dim rst As DAO.Recordset
            Dim fld As DAO.Field
            Dim s_Teach_Name As String
            Dim s_ID As Long
    
            Set rst = CurrentDb.OpenRecordset("Select * From Temp3")
            rst.MoveLast: rst.MoveFirst
            RC = rst.RecordCount
    
            For i = 1 To RC

                If i = 7 And Len(rst("F1") & "") <> 0 Then
            
                    sSubject = rst("F1")
                    s_ID = rst!ID + (RC - 7)    'get the Auto_ID "ID" number for Record#8, then add to it "Total Records" - 8
                    s_Teach_Name = DLookup("[F5]", "Temp3", "[ID]=" & s_ID)
                    s_Teach_Name = Replace(s_Teach_Name, "اسم المعلم ", "")
                
                ElseIf i = 8 And Len(rst("F1") & "") <> 0 Then
            
                    sSubject = rst("F1")
                    s_ID = rst!ID + (RC - 8)    'get the Auto_ID "ID" number for Record#8, then add to it "Total Records" - 8
                    s_Teach_Name = DLookup("[F5]", "Temp3", "[ID]=" & s_ID)
                    s_Teach_Name = Replace(s_Teach_Name, "اسم المعلم ", "")
                
                ElseIf i = 11 And Len(rst("F1") & "") <> 0 Then
            
                    sClass = rst("F1")
                    
                ElseIf i = 12 And Len(rst("F1") & "") <> 0 Then
            
                    sClass = rst("F1")
                End If
        
                For Each fld In rst.Fields

            
                    If fld.Value = "المجموع" Then
                
                        myID = rst!ID + 1
                        smark = fld.Name
                        fld_Number = Mid(smark, 2)
                        rst.MoveNext
                  '
                        If IsNumeric(rst("F" & fld_Number + 16).Value) Then
                            sID = rst("F" & fld_Number + 16).Name
                            sName = rst("F" & fld_Number + 12).Name
                            s1 = rst("F" & fld_Number + 10).Name
                            s2 = rst("F" & fld_Number + 9).Name
                            s3 = rst("F" & fld_Number + 7).Name
                            s4 = rst("F" & fld_Number + 5).Name
                            s5 = rst("F" & fld_Number + 2).Name
                            s6 = rst("F" & fld_Number + 1).Name
                            s7 = rst("F" & fld_Number + 21).Name
                            s8 = rst("F" & fld_Number + 21).Name
                            s9 = rst("F" & fld_Number + 21).Name
                            s10 = rst("F" & fld_Number + 21).Name
                   '
                        ElseIf IsNumeric(rst("F" & fld_Number + 20).Value) Then
                            sID = rst("F" & fld_Number + 20).Name
                            sName = rst("F" & fld_Number + 18).Name
                            s1 = rst("F" & fld_Number + 17).Name
                            s2 = rst("F" & fld_Number + 15).Name
                            s3 = rst("F" & fld_Number + 12).Name
                            s4 = rst("F" & fld_Number + 10).Name
                            s5 = rst("F" & fld_Number + 9).Name
                            s6 = rst("F" & fld_Number + 7).Name
                            s7 = rst("F" & fld_Number + 5).Name
                            s8 = rst("F" & fld_Number + 2).Name
                            s9 = rst("F" & fld_Number + 1).Name
                            s10 = rst("F" & fld_Number + 21).Name
                 '
                        ElseIf IsNumeric(rst("F" & fld_Number + 19).Value) Then
                            sID = rst("F" & fld_Number + 19).Name
                            sName = rst("F" & fld_Number + 17).Name
                            s1 = rst("F" & fld_Number + 15).Name
                            s2 = rst("F" & fld_Number + 12).Name
                            s3 = rst("F" & fld_Number + 10).Name
                            s4 = rst("F" & fld_Number + 9).Name
                            s5 = rst("F" & fld_Number + 7).Name
                            s6 = rst("F" & fld_Number + 5).Name
                            s7 = rst("F" & fld_Number + 2).Name
                            s8 = rst("F" & fld_Number + 1).Name
                            s9 = rst("F" & fld_Number + 21).Name
                            s10 = rst("F" & fld_Number + 21).Name
                 '
                        ElseIf IsNumeric(rst("F" & fld_Number + 17).Value) Then
                            sID = rst("F" & fld_Number + 17).Name
                            sName = rst("F" & fld_Number + 15).Name
                            s1 = rst("F" & fld_Number + 12).Name
                            s2 = rst("F" & fld_Number + 10).Name
                            s3 = rst("F" & fld_Number + 9).Name
                            s4 = rst("F" & fld_Number + 7).Name
                            s5 = rst("F" & fld_Number + 5).Name
                            s6 = rst("F" & fld_Number + 2).Name
                            s7 = rst("F" & fld_Number + 1).Name
                            s8 = rst("F" & fld_Number + 21).Name
                            s9 = rst("F" & fld_Number + 21).Name
                            s10 = rst("F" & fld_Number + 21).Name
                   '
                        ElseIf IsNumeric(rst("F" & fld_Number + 15).Value) Then
                            sID = rst("F" & fld_Number + 15).Name
                            sName = rst("F" & fld_Number + 10).Name
                            s1 = rst("F" & fld_Number + 9).Name
                            s2 = rst("F" & fld_Number + 7).Name
                            s3 = rst("F" & fld_Number + 5).Name
                            s4 = rst("F" & fld_Number + 2).Name
                            s5 = rst("F" & fld_Number + 1).Name
                            s6 = rst("F" & fld_Number + 21).Name
                            s7 = rst("F" & fld_Number + 21).Name
                            s8 = rst("F" & fld_Number + 21).Name
                            s9 = rst("F" & fld_Number + 21).Name
                            s10 = rst("F" & fld_Number + 21).Name
                         
                                         
                        End If
        
                    GoTo Got_the_info
                End If
            Next
        
            rst.MoveNext
        Next i

Got_the_info:
    
    mySQL = "INSERT INTO mark ( StName, StuId, S_Sum, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, S_Subject, S_Class, Teach_Name  )"
    mySQL = mySQL & " SELECT [" & sName & "], [" & sID & "], [" & smark & "], [" & s1 & "], [" & s2 & "], [" & s3 & "], [" & s4 & "], [" & s5 & "], [" & s6 & "], [" & s7 & "], [" & s8 & "], [" & s9 & "], [" & s10 & "], '" & sSubject & "', '" & sClass & "', '" & s_Teach_Name & "'"
    mySQL = mySQL & " FROM Temp3"
    mySQL = mySQL & " GROUP BY [" & sName & "], [" & sID & "], [" & smark & "], [" & s1 & "], [" & s2 & "], [" & s3 & "], [" & s4 & "], [" & s5 & "], [" & s6 & "], [" & s7 & "], [" & s8 & "], [" & s9 & "], [" & s10 & "]"
    mySQL = mySQL & " HAVING [" & smark & "]<>'المجموع'"
   'Debug.Print mySQL
   
   CurrentDb.Execute (mySQL)
    
   CurrentDb.Execute ("Delete * From Temp3")
Next lngCount
strFile = Dir()
Loop

Set colWorksheets = Nothing
Forms!Mark!barna = Forms!Mark!barna & vbCr & "تمت عملية الاستيراد بنجاح .. انتقل إلى التقارير "


End Function

 

مجلد جديد (2).rar

تم تعديل مارس 10, 2020 بواسطه emam1424

[عفرنس]

الأستاذ jjafferr 

تم تعديل الكود على هذا الشكل .. 

لكن يعطيني الخطأ التالي : 

[jjafferr]

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

 

رجاء اعطنا اكبر كمية من التفاصيل لوسمحت 🙂

ماني فاهم شو اللي تريد تعمله في البرنامج المرفق ، هل فيه مشكلة ؟

 

جعفر

[عفرنس]

منذ ساعه, jjafferr said:

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

 

رجاء اعطنا اكبر كمية من التفاصيل لوسمحت 🙂

ماني فاهم شو اللي تريد تعمله في البرنامج المرفق ، هل فيه مشكلة ؟

 

جعفر

اريد باختصار استيراد اسم المعلم من ملف اكسل المرفق 

ولك مني خالص الدعاء 

تم تعديل مارس 10, 2020 بواسطه emam1424

[jjafferr]

تفضل 🙂

والمعلم على رأسي 🙂

 

جعفر

1180.02.MARK.zip

[عفرنس]

16 ساعات مضت, jjafferr said:

تفضل 🙂

والمعلم على رأسي 🙂

 

جعفر

1180.02.MARK.zip 77.28 kB · 12 تنزيلات

تم المطلوب بنجاح .. 

شكر الله لك وغفر ذنبك .. 😘