مساعدة في (كود VBA) نسخ ولصق خلية عدة مرات معينة عند كل عملية جلب بيانات

[Rachid-VBA]

بسم الله الرحمان الرحيم

السلام عليكم أعضاء منتدى اوفيسنا

بدون اطالة .. المطلوب كالاتي

لدي ملفات نفس الامتداد و الفورم

محتوى الملف من الداخل

قمت بانشاء ملف 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

 

[حسونة حسين]

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

مرحبا بك في اول مشاركه لك ..هلا رفعت ملف ليتسنى للاساتذة المساعدة

 

[محمد يوسف ابو يوسف]

السلام عليكم

كما تفضل اخي..حسونة.. لا تنتظر مساعدة دون ارسال ملف مدعوم بشرح كافي

علي العموم جرب

بدل من

ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteValues

الي

ThisWorkbook.Worksheets("Sheet2").Range("A2").PasteSpecial xlPasteValues

[Rachid-VBA]

عذرًا على الإطالة   .....تفضلوا البرنامج مع ملفات التجربة ..عذار ... تفضل

جلب النتائج.xlsmتحليل النتائج الفصل الأول 2018-2019 رابعة متوسط 01.xls