طلب كود إدراج اسم الملف الذي تنسخ منه البيانات في العمود G

[hicham2610]

السلام عليكم

هل من إمكانية لإضافة سطر لهذا الكود يُمَكِّنُ من إدراج اسم الملف الذي تِؤخذ منه البيانات في العمود G من ورقة "ُُExamen"

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

Sub imprtdonnéesplusieursfichiers()
Dim CD As Workbook 'مرتب التصدير
Dim OD As Worksheet 'ورقة التصدير
Dim CA As String 'الموقع
Dim F As String 'الملف
Dim CS As Workbook 'مرتب مصدر البيانات
Dim OS As Worksheet 'ورقة مصدر البيانات
Dim DEST As Range 'خلية التصدير
'منع اهتزاز الشاشة
Application.ScreenUpdating = False
  Application.CutCopyMode = False
  'effece anciennes données
  Range("B18:I100000").Value = ""
Set CD = ThisWorkbook 'تعريف مرتب التصدير
Set OD = CD.Worksheets("Examen") 'تعريف ورقة التصدير
CA = CD.Path & "\" 'تعريف الموقع
F = Dir(CA & "note*.xlsx?") 'تعريف الملف المبحوث عنه
Do While F <> "" 'البحث مهما يوجد من ملفات
    If Not F = CD.Name Then 'إن كان الاسم يختلف
        Set CS = Workbooks.Open(CA & F) 'تعريف الملف المنبع المفتوح
        Set OS = CS.Worksheets("NotesEX") 'ورقة المنبع
         'خلية الكتابة
        Set DEST = IIf(OD.Range("C18").Value = "", OD.Range("C18"), OD.Cells(Application.Rows.Count, "C").End(xlUp).Offset(1, 0))
        OS.Range("C18:F118").Copy DEST 'المجال المنسوخ
        CS.Close False 'ferme le classeur source sans enregistrer
         F = Dir 'الملف الموالي
    End If 'نهاية الشرط
Loop 'boucle
OD.Activate 'تنشيط الورقة
Application.ScreenUpdating = True
  Application.CutCopyMode = True
End Sub

الملفات.rar

[محمد هشام.]

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

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

 

ملاحظة:

بالنسبة لهدا الموضوع اخي الكريم  ادا  لم اكن مخطأ  فهو نفس الفكرة  ولربما افضل  من وجهة نظري سواءا من ناحية النتائج .او  امكانية  العمل  على ملف واحد فقط  بدل كثرة الملفات .....هدا في حالة لم  تكن هناك ضرورة لدالك

الملفات.zip

[hicham2610]

السلام عليكم

الأخ الكريم

شكرا لردك

لكن للأسف ذلك الحل غير وارد على الإطلاق

ففي الأصل الملفات المستوردة تكون محمية من الموقع ، لكني بطريقة فككت تشفيرها وعدلت عليها عبر نقص أعمدة تنقيط المواد ومعلومات المؤسسة وك\لك عدلت المعطيات الشخصية

وأريد الاشتغال عليها لمساعدة باقي الزملاء، 

شكرا لاهتمامك

[hicham2610]

السلام عليكم

شاهدت فيديو للأخ الكريم samir Tobeil  ت"جميع البيانات من ملفات اكسيل مغلقة دون فتحها حتى لو كانت بصيغ مختلفة VBA"

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

لكن لم ينجح معي بعد  ..الكود:

Sub information()
Dim wb As Workbook, lr1 As Integer, lr2 As Integer
Dim fil As Variant, dat As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lr1 = Sheets("Examen").Cells(Rows.Count, 2).End(xlUp).Row
 Sheets("Examen").Range("B18:I" & lr1 + 1).ClearContents
 INF = ThisWorkbook.Path
'fil = Dir(INF & "\*.xl??")
fil = Dir(INF & "\*.xlsx")

Do While fil <> ""
  If fil <> "fichier1.xlsm" Then
  Set wb = Workbooks.Open(INF & "\" & fil)
  
 lr1 = Workbooks("fichier1.xlsm").Sheets("Examen").Cells(Rows.Count, 3).End(xlUp).Row

 lr2 = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
 ActiveSheet.Range("C18:F" & lr2).Copy Workbooks("fichier1").Sheets("Examen").Range("C" & lr1 + 1).past
 dep = Right(ActiveWorkbook.Name, Application.Search(".", ActiveWorkbook.Name) - 1)
 'thisworkbook.Sheets("examen").range("g"&lr1+1&":g" & lr1+lr2-1)=dep
 
   Workbooks("fichier1").Sheets("Examen").Range("g" & lr1 + 1 & ":g" & lr1 + lr2 - 1) = dep
   ActiveWorkbook.Close
   fil = Dir
 End If
 Loop
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True

End Sub

 

[hicham2610]

الحمد لله تمكنت من حل المشكل بالكود الأخير

الحل هو كتابة الامتداد داخل الكود

"fichier1.xlsm"  وليس فقط  fichier1