ترحيل بيانات حضور الدورات يوميا وتجميعها في شيت خاص بكل شهر

[بيسان]

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

 

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

 

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

 

تم ارفاق الشيت لمزيد من التوضيح.

 

شكرا للجميع مقدما.

نظام حضور الدورات التدريبية.rar

[بيسان]

السلام عليكم..

 

الرجاء مساعدتي في عمل كود يقوم بترحيل البيانات حسب التاريخ المدخل الى الشيت الخاص بكل شهر في الملف.

 

 

شاكرة تعاونكم الجميل..

[عبدالله باقشير]

السلام عليكم

 

جرب الكود التالي للترحيل

Sub Macro1()
Dim ShName As String
Dim Lr As Long
ShName = Format(Range("C1"), "MMMM")
With Worksheets(ShName)
    Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    .Range("A" & Lr).Resize(4, 1).Value = Range("C1").Value
    Range("B7:L7").Resize(4).Copy
    .Range("B" & Lr).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub

المرفق 2010

نظام حضور الدورات التدريبية.rar

تحياتي

[بيسان]

الاخ الفاضل عبدالله .. شكرا جزيلا وجزاك الله كل خير ولكن الترحيل لم يحدث للبيانات الخاصة بالكورس كاسم الكورس واسم الاستاذ وتاريخ اليوم ودرجة النجاح .. بالرغم من ذلك الكود اكثر من رائع ويعمل بشكل ممتاز 

 

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

 

 

نظام حضور الدورات التدريبية.zip

[عبدالله باقشير]

السلام عليكم

كود الترحيل

Sub kh_Trheel()
Dim ShName As String
Dim Lr As Long
Dim c As Integer
ShName = Format(Range("C1"), "mmmm")
Application.ScreenUpdating = False
On Error GoTo 1
With Worksheets(ShName)
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
    .Cells(1, c).Value = Range("C1").Value
    .Cells(2, c).Resize(3, 1).Value = Range("K1:K3").Value
    Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    .Range("A" & Lr).Resize(4, 1).Value = Range("C1").Value
    Range("B7:L7").Resize(4).Copy
    .Range("B" & Lr).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
kh_Clear
1:
Application.ScreenUpdating = True
End Sub

كود المسح وابقاء المعادلات

'  كود المسح بدون مسح المعادلات
Sub kh_Clear()
On Error Resume Next
Range("B7:L7").Resize(4).SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End Sub

شاهد المرفق 2010

نظام حضور الدورات التدريبية+.rar

 

 

[بيسان]

السلام عليكم..

 

في البداية اود ان اشكرك بشدة على الكود الاكثر من رائع ولكني اتمنى ان تقوم بشرح الكود ليتسنى لي معرفة التعديلات التي اجريها في حال تم تغيير موقع الخلايا او اسماء الشيتات حيث انني حاولت كتابة الكود باستخدام جهاز مختلف يحوي اصدار اكسل 2010 ولكنه  لم يعمل الا على 2007 

 

شكرا لك مرة اخرى وكل عام وانتم بخير

[أبو أنس80]

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

[عبدالله باقشير]

السلام عليكم..

 

في البداية اود ان اشكرك بشدة على الكود الاكثر من رائع ولكني اتمنى ان تقوم بشرح الكود ليتسنى لي معرفة التعديلات التي اجريها في حال تم تغيير موقع الخلايا او اسماء الشيتات حيث انني حاولت كتابة الكود باستخدام جهاز مختلف يحوي اصدار اكسل 2010 ولكنه  لم يعمل الا على 2007 

 

شكرا لك مرة اخرى وكل عام وانتم بخير

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

وهذا افضل ليعمل الكود في اي جهاز

Sub kh_Trheel()
Dim ShName As String
Dim Lr As Long
Dim c As Integer
'  استخراج رقم الشهرلاستخدامة لاسم الورقة
ShName = Month(Range("C1"))
Application.ScreenUpdating = False
On Error GoTo 1
With Worksheets(ShName)
'  آخر عمود  في الصف الاول لورقة الشهر زايدا واحد

    c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
    '  نقل التاريخ واسم الكورس وغيره في الصفوف الاربعة الاولى
    .Cells(1, c).Value = Range("C1").Value
    .Cells(2, c).Value = Range("K1").Value
    .Cells(3, c).Value = Range("K2").Value
    .Cells(4, c).Value = Range("K3").Value
    
    '  آخر صف  في العمود الاول لورقة الشهر زايدا واحد

    Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        '  نقل التاريخ  في الصفوف الاربعة في العمود الاول

    .Range("A" & Lr).Resize(4, 1).Value = Range("C1").Value
    
    '   نسخ الجدول
    Range("B7:L7").Resize(4).Copy
    '  لصق الجدول
    .Range("B" & Lr).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False

'  مسح الجدول
kh_Clear
1:
Application.ScreenUpdating = True
End Sub

'  كود المسح بدون مسح المعادلات
Sub kh_Clear()
On Error Resume Next
Range("B7:L7").Resize(4).SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End Sub

تحياتي

نظام حضور الدورات التدريبية++.rar

[بيسان]

الاخ الفاضل عبدالله باقشير .. الحقيقة انا اعجز عن شكرك وشرحك للكود بطريقة مميزة استطعت من خلالها زيادة صفوف واعمدة واضافة المزيد من التعديلات بدون اي مشاكل ولكني واجهت مشكلة بسيطة وهي ان الصفوف تنسخ بمقدار معين كل مرة حتى ولو كانت الخلايا فارغة ..!! وبما ان عدد الطالبات الحاضرات يكون متغير يوميا أتمنى ان تساعدني في عمل تعديل لجعل الكود ينسخ الصفوف التي تحتوي على بيانات فقط وتجاهل اي صفوف فارغة.

 

كما اتمنى ان يقوم الكود بمسح بيانات الكورس ايضا بعد نقلها للشيت المعني ويبقى الفورم بدون اي بيانات تمهيدا لتعبئتها من جديد.

 

اتمنى ان لا اكون قد اثقلت عليكم ولكن كرم اخلاقكم يغريني لطلب المزيد ... فجزاكم الله عنا كل خير

[عبدالله باقشير]

الاخ الفاضل عبدالله باقشير .. الحقيقة انا اعجز عن شكرك وشرحك للكود بطريقة مميزة استطعت من خلالها زيادة صفوف واعمدة واضافة المزيد من التعديلات بدون اي مشاكل ولكني واجهت مشكلة بسيطة وهي ان الصفوف تنسخ بمقدار معين كل مرة حتى ولو كانت الخلايا فارغة ..!! وبما ان عدد الطالبات الحاضرات يكون متغير يوميا أتمنى ان تساعدني في عمل تعديل لجعل الكود ينسخ الصفوف التي تحتوي على بيانات فقط وتجاهل اي صفوف فارغة.

 

كما اتمنى ان يقوم الكود بمسح بيانات الكورس ايضا بعد نقلها للشيت المعني ويبقى الفورم بدون اي بيانات تمهيدا لتعبئتها من جديد.

 

اتمنى ان لا اكون قد اثقلت عليكم ولكن كرم اخلاقكم يغريني لطلب المزيد ... فجزاكم الله عنا كل خير

عدد الصفوف في الفورمة حسب اكبر قيمة للتسلسل في النطاق

A7:A10

Sub kh_Trheel()
Dim ShName As String
Dim Lr As Long
Dim c As Integer, Cont As Integer
'  استخراج رقم الشهرلاستخدامة لاسم الورقة
ShName = Month(Range("C1"))

' A7:A10 عدد الصفوف في الفورمة حسب اكبر قيمة للتسلسل في النطاق

Cont = WorksheetFunction.Max(Range("A7:A10"))

Application.ScreenUpdating = False
On Error GoTo 1
With Worksheets(ShName)
'  آخر عمود  في الصف الاول لورقة الشهر زايدا واحد

    c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
    '  نقل التاريخ واسم الكورس وغيره في الصفوف الاربعة الاولى
    .Cells(1, c).Value = Range("C1").Value
    .Cells(2, c).Value = Range("K1").Value
    .Cells(3, c).Value = Range("K2").Value
    .Cells(4, c).Value = Range("K3").Value
    
    '  آخر صف  في العمود الاول لورقة الشهر زايدا واحد

    Lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        '  نقل التاريخ  في الصفوف الاربعة في العمود الاول

    .Range("A" & Lr).Resize(Cont, 1).Value = Range("C1").Value
    
    '   نسخ الجدول
    Range("B7:L7").Resize(Cont).Copy
    '  لصق الجدول
    .Range("B" & Lr).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False

'  مسح الجدول
kh_Clear
1:
Application.ScreenUpdating = True
End Sub

'  كود المسح بدون مسح المعادلات
Sub kh_Clear()
On Error Resume Next
Range("A7:L10").SpecialCells(xlCellTypeConstants).ClearContents
Range("K1:K4").ClearContents
On Error GoTo 0
End Sub