بسم الله الرحمان الرحيم
السلام عليكم أعضاء منتدى اوفيسنا
بدون اطالة .. المطلوب كالاتي
لدي ملفات نفس الامتداد و الفورم
محتوى الملف من الداخل
قمت بانشاء ملف XLSM جاهز لجلب النتائج من العمود (الرقم) الى غاية العمود معدل (الفصل1)
بعد عملية الجلبفي sheet1 النتيجة كالآتي:
وفي نفس الوقت يقوم بنسخ عنوان الجدول في الخلية A5 في الصورة الاولى ولصقها في sheet2 في الخلية A1
اما في الخلية C2 بانشاء معدالة تقوم باختصار العنوان الرئيسي الى رمز للقسم الذي تم جلب نتائج تلاميذه وهذه المعادلة
بعدها يقوم بنسخ الرمز ولصقه في الورقة sheet1
وهنا المشكلة....... عند عملية اللصق ... يقوم بلصقها عند اول خلية مع اول تلميذ ... نفس العملية عند جلب نتائج القسم الثاني ... المطلوب اريدتكرار لصق رمزالقسم عدة مرات مع نهاية صف كل قسم
مثل ماهو في الصورة
وهذا هو الكود الذي يقوم بالعملية
Sub Import_4M()
Dim filetoopen As Variant
Dim openbook As Workbook
Dim lastrow As Long
Dim lastrow1 As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
filetoopen = Application.GetOpenFilename(Title:="Browse your file", filefilter:="Excel files (*.xls),*.xls")
If filetoopen <> False Then
Set openbook = Application.Workbooks.Open(filetoopen)
lastrow1 = openbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row - 1
openbook.Sheets(1).Range("A7:T" & lastrow1).Copy
lastrow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row + 1
ThisWorkbook.Worksheets("Sheet1").Range("B" & lastrow).PasteSpecial xlPasteValues
openbook.Sheets(1).Range("A5").Copy
ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteValues
ThisWorkbook.Worksheets("Sheet2").Range("C1").Copy
ThisWorkbook.Worksheets("Sheet1").Range("A" & lastrow).PasteSpecial xlPasteValues
openbook.Close False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub