تصدير ملف اكسل وحفظه في مجلد خاص حسب المادة

[عفرنس]

لدي مجلد باسم ( السجل الالكتروني ) . هذا المجلد يحتوي على ( عدة مجلدات ) كل مجلد باسم المادة 

أريد بعد تصدير ملف الاكسل لمادة الرياضيات مثلا يحفظ في المجلد الخاص بمادة الرياضيات الموجود في مجلد ( السجل الإلكتروني ) 

أرجو أن يكون مطلوبي واضحا 

ولكم جزيل الشكر .. 

برنامج تصدير الطلاب للسجل الالكتروني حسب المادة معتمد.mdb

[د.كاف يار]

اخي الكريم 

لانشاء مجلد بإسم المادة  استخدم هذا الكود

Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String

    Set fso = CreateObject("scripting.filesystemobject")
    fldrname =[text3]
    fldrpath = CurrentProject.Path & "\السجل الإلكتروني\" & fldrname
    If Not fso.FolderExists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If

 

و هذا تعديل لمتغيير كود التصدير فقط الصقه

Dim LExcelOriginal      As String
Dim LExcelCopyOf        As String
    LExcelOriginal = sXlsFile
    LExcelCopyOf = CurrentProject.Path & "\السجل الإلكتروني\" & [text3] & "\" & [Forms]![FORM2]![text2] & "_..xlsm"
        FileCopy LExcelOriginal, LExcelCopyOf

 

 

 

 

 

تم تعديل أغسطس 14, 2020 بواسطه د.كاف يار

[عفرنس]

5 دقائق مضت, د.كاف يار said:

اخي الكريم 

لانشاء مجلد بإسم المادة  استخدم هذا الكود

Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String

    Set fso = CreateObject("scripting.filesystemobject")
    fldrname =[text3]
    fldrpath = CurrentProject.Path & "\السجل الإلكتروني\" & fldrname
    If Not fso.FolderExists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If

 

و هذا تعديل لمتغيير كود التصدير فقط الصقه

Dim LExcelOriginal      As String
Dim LExcelCopyOf        As String
    LExcelOriginal = sXlsFile
    LExcelCopyOf = CurrentProject.Path & "\السجل الإلكتروني\" & [text3] & "\" & [Forms]![FORM2]![text2] & "_..xlsm"
        FileCopy LExcelOriginal, LExcelCopyOf

 

 

 

 

 

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

ياليت لو تعينني على التعديل في المرفق ... 

[عفرنس]

12 دقائق مضت, د.كاف يار said:

لانشاء مجلد بإسم المادة  استخدم هذا الكود

أين يتم وضع الكود ؟؟ 

[عفرنس]

Public Function barnaExcelFile(sXlsFile As String)
Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String

    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = [text3]
    fldrpath = CurrentProject.Path & "\السجل الالكتروني\" & fldrname
    If Not fso.FolderExists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If

Dim LExcelOriginal      As String
Dim LExcelCopyOf        As String
    LExcelOriginal = sXlsFile
LExcelCopyOf = CurrentProject.Path & "\السجل الالكتروني\" & [text3] & "\" & [Forms]![FORM2]![text2] & "_..xlsm"
FileCopy LExcelOriginal, LExcelCopyOf

Dim db1          As DAO.Database
Dim Rst1         As DAO.Recordset
Set db1 = CurrentDb
Dim objExcel     As Object
Dim objWorkbook  As Object
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(LExcelCopyOf)
  
    Set Rst1 = db1.OpenRecordset("temp", dbOpenSnapshot)
objWorkbook.Sheets(2).range("H1").Value = "اسماء طلاب الصف " & "(" & [Forms]![FORM2]![text1] & ")" & " -- " & "(" & [Forms]![FORM2]![text2] & ")" & " المادة " & "(" & [Forms]![FORM2]![text3] & ")"
    With Rst1
        If .RecordCount <> 0 Then
            .MoveFirst
            objWorkbook.Sheets(2).range("b5").CopyFromRecordset Rst1
            objWorkbook.Sheets(2).range("b5").Select
        End If
    End With
  objExcel.DisplayAlerts = True
  objWorkbook.Close SaveChanges:=True
  Set objWorkbook = Nothing
  objExcel.Quit

Set objExcel = Nothing
Set Rst1 = Nothing
Set db1 = Nothing
VBA.Shell "Explorer.exe " & Chr(34) & LExcelCopyOf & Chr(34), vbNormalFocus
DoCmd.DeleteObject acTable, "temp"
End Function

@د.كاف يار

هل هذا صحيح ؟؟ 

[د.كاف يار]

نعم صحيح