أ / محمد صالح

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

حسب فهمي للمطلوب :
وهو تحويل الأرقام الموجودة في ورقة1 من D4:L65 إلى ما يقابلها من أسماء في نفس المدى ووضغها في شيت ورقة2 . مع العلم أن الأسماء سواء في ورقة1 أو ورقة2 اعتمادا على رقم المسلسل 
للوصول للمطلوب بإذن الله يمكنك:
* حذف المحتويات للخلايا D4:L65
* حذف تنسيقات لون الخلفية ولن النص في نفس النطاق
* استعمال المعادلة التالية في الخلية D4
=IFERROR(VLOOKUP(ورقة1!D4:L65,$B$4:$C$65,2,0),"ح") * إضافة تنسيق شرطي للخلية D4 باستعمال المعادلة التالية
=COUNTIF($D4:$L4,D4)>1 ويطبق على المدى 
=$D$4:$L$65 ولا أدري ما سبب الصف الفارغ بين مسلسل 31 و 32
بالتوفيق

يمكنك وضع هذه المعادلة في الخلية A6 ثم سحب المعادلة لأسفل
=IFERROR(INDEX('date out'!B$1:I$100,SMALL(IF('date out'!$A$1:$A$100=$A$1,ROW('date out'!$A$1:$A$100)),ROW()-5),{1,2,3,4,5,6,7,8}),"") وهذا ملفك إن كنت لا تعلم كيف تضيف المعادلة مثل بعض الأعضاء
بالتوفيق
Copy of BİLDİRİM LİSTESİ.xlsx

ما دمت مصرا على تجاهل الخطأ في تنظيم البيانات واختلاف عدد السطور في كل عمود عن غيره في نفس الصف
هذا الكود يبحث عن كلمة بكالوريوس ويجلب البيانات الموجودة في نفس السطر من جميع الأعمدة
ويضعها في الأعمدة بداية من H:M
مع تجاهل أي خطأ يقابله
لذلك أنا شخصيا لست متأكدا بنسبة 100% من صحة النتائج لأن البيانات غير صحيحة من البداية
Sub MasSplitText() Dim MyArray() As String, newcol As Long, i As Variant, lr As Long On Error Resume Next lr = Cells(Rows.Count, 1).End(3).Row Range("h2:m" & lr).ClearContents For c = 1 To 6 For rw = 2 To lr MyArray = Split(Cells(rw, 2), Chr(10)) newcol = c + 7 For i = 0 To UBound(MyArray) If MyArray(i) = "بكالوريوس" Then Cells(rw, newcol) = Split(Cells(rw, c), Chr(10))(i) Next i Next rw Next c MsgBox "Done by mr-mas.com" End Sub بالتوفيق

يمكنك وضع هذه المعادلة في الخلية A6 ثم سحب المعادلة لأسفل
=IFERROR(INDEX('date out'!B$1:I$100,SMALL(IF('date out'!$A$1:$A$100=$A$1,ROW('date out'!$A$1:$A$100)),ROW()-5),{1,2,3,4,5,6,7,8}),"") وهذا ملفك إن كنت لا تعلم كيف تضيف المعادلة مثل بعض الأعضاء
بالتوفيق
Copy of BİLDİRİM LİSTESİ.xlsx

عليكم السلام ورحمة الله وبركاته
يمكنك وضع هذه المعادلة في الخلية G5
=EDATE(F5,COUNT(I5:R5)-1) ثم سحبها لأسفل
وهي لعد الشهور المسجلة في I5:R5 وإضافتها على تاريخ بداية الاشتراك
إن شاء يكون المطلوب
بالتوفيق

بعد إذن جميع الأصدقاء المشاركين في هذا الموضوع الرائع
هذا جهدي المتواضع لتحميل الملفات من جوجل درايف بنفس الاسم والامتداد
فقط تحتاج رابط الملف كاملا وأن يكون الملف عاما (مشاركا مع الجميع)
الكود يعالج مشكلة أسماء الملفات العربية
صالح للنواتين 32بت وكذلك 64بت
يعمل في كل التطبيقات التي تستعمل vba
يوضع هذا الكود في موديول جديد
Sub DownloadFromGD(GDriveURL As String) Dim myURL As String Dim FileID As String Dim xmlhttp As Object Dim name0 As Variant Dim oStream As Object FileID = Split(Split(GDriveURL, "/d/")(1), "/")(0) myURL = "http://drive.google.com/u/0/uc?id=" & FileID & "&export=download" Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP") xmlhttp.Open "GET", myURL, False xmlhttp.Send name0 = DECODEURL(xmlhttp.getResponseHeader("Content-Disposition")) If name0 = "" Then MsgBox "الملف غير موجود في الموقع" Exit Sub End If name0 = Split(name0, "*=UTF-8''")(1) 'split after *=UTF-8'' to get utf8 names If xmlhttp.Status = 200 Then Set oStream = CreateObject("ADODB.Stream") oStream.Open oStream.Type = 1 oStream.Write xmlhttp.responseBody oStream.SaveToFile CurrentProject.Path & "\" & name0, 2 ' 1 = no overwrite, 2 = overwrite oStream.Close End If Set xmlhttp = Nothing Set Stream = Nothing MsgBox "تم تحميل الملف في نفس مسار البرنامج باسم: " & name0 End Sub Function DECODEURL(varText As Variant) Static objHtmlfile As Object If objHtmlfile Is Nothing Then Set objHtmlfile = CreateObject("htmlfile") objHtmlfile.parentWindow.execScript "function decode(s) {return decodeURIComponent(s)}", "jscript" End If DECODEURL = objHtmlfile.parentWindow.decode(varText) End Function طريقة استخدام الكود مثل السطر المكتوب في الإجراء test أو يمكن وضعه عند الضغط على زر مثلا
ويتكون هذا السطر من كتابة اسم الاجراء DpwnloadFromGD ثم رابط الملف المراد تحميله بين علامتي تنصيص ويمكن استخدام قيمة مربع النص بدلا من تثبيت رابط الموقع
Sub test() DownloadFromGD "https://drive.google.com/file/d/18jrvTxgR1QTzwm8YaJHIvsdOmqj02L2x/view" End Sub ولا تنسوني من صالح دعائكم
بالتوفيق للجميع

عليكم السلام
سيتم الجمع بصورة تلقائية إذا تم إدراج الصفوف الجديدة قبل الصف الأخير (الذي قبل الإجمالي مباشرة)
ولكي يتم ذلك نحدد الصف الثالث ثم نضغط كلك يمين ثم نختار إدراج insert
وهكذا في كل إدراج
بالتوفيق

بإذن الله يفيدك هذا التعديل 
رغم اني كنت أتوقع وجود محاولة منكم في المعادلات البسيطة 
بالتوفيق
حصر العجز والزيادة فى الحصص.xlsx

يمكنك استعمال هذا الكود 
sub fillblank() lr = cells(rows.count, 1).end(xlup).row for n=2 to lr if cells(n, 1).value <> "" then customer = cells(n, 1).value else cells(n, 1).value = customer end if next n msgbox "Done by mr-mas.com" end sub بالتوفيق 

بعد إذن الجميع
هذا ملفك بعد تصحيح الخطأ في الكود
الخطأ في نقل الكود وليس الكود الأصلي
وينتج هذا الخطأ عن عدم فهم دلالات الأرقام والمتغيرات في الكود
بالتوفيق
مجمع الشيتات.xlsm

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

المشكلة الأولى تكمن في أن النص الموجودج في مربع النص هو نص string وليس مصفوفة array
والحل
mycols = Split(textbox2.value, ",") لتحويل النص إلى مصفوفة
ولتحويل العنصر في المصفوفة من نص إلى رقم نستعمل int في هذا السطر
a(ii + 1, j) = ws.Cells(i, Int(myCols(ii))).Value والمشكلة الثانية تكمن في أن الخلية الفارغة قيمتها صفر ولا يوجد عمود رقمه صفر
والحل ألا توجد خلية فارغة
وهذا ملفك بعد التعديل: لأنه في الغالب يوجد مشكلة في تطبيق المعلومة المستفادة من الإجابة
بالتوفيق
listbox dynamic.xlsb

يمكنك استعمال التنسيق الشرطي
رسائل تنبيه من عدة اعمدة.xls

يمكنك استعمال التنسيق الشرطي بمعادلة مثل
=OR(COUNTIF($F$6:$I$11,C6)>0,COUNTIF($L$14:$N$19,C6)>0) وتطبق على المدى المطلوب
بالتوفيق
عدم السماح بتكرار.xlsx

يمكنك استعمال هذا الاجراء
Sub merge2cols() rng1Count = Cells(Rows.Count, "B").End(xlUp).Row - 6 rng2Count = Cells(Rows.Count, "C").End(xlUp).Row - 6 lr = Cells(Rows.Count, "E").End(xlUp).Row + 1 Range("E" & lr & ":E" & rng1Count + lr - 1).Value = Range("B7:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value lr = Cells(Rows.Count, "E").End(xlUp).Row + 1 Range("E" & lr & ":E" & rng2Count + lr - 1).Value = Range("C7:C" & Cells(Rows.Count, "C").End(xlUp).Row).Value End Sub بالتوفيق
 
 
نقل عمودين في عمود.xlsb

يمكنك تحويل المعادلة الي كود 
مثلا لو أردنا تحويل العمود D نستعمل هذا الاجراء مع ربطه بزر 
مع حفظ الملف بصيفة تدعم الاكواد مثل xlsb
Sub mrmas() Range("d2:d101").Formula = "=rand()" Range("d2:d101").Value = Range("d2:d101").Value End Sub بالتوفيق 

عليكم السلام ورحمة الله وبركاته
معادلتك صحيحة ويمكن اختصارها لهذه
=IFERROR(VLOOKUP(F16,data!$A$4:$K$57,MATCH(C16,data!$A$2:$K$2,0))*1.05^($C$14-2012),"") بالتوفيق

يمكنك استعمال هذه الطريقة
بوضع السيريلات المسموحة في مصفوفة myserials بينها فاصلة 
Private Sub Workbook_Open() myserials = Array("589CC486", "mr-mas.com", "") myhd = Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("C:").SerialNumber) If Not UBound(Filter(myserials, myhd)) > -1 Then MsgBox "أي رسالة هنا" ThisWorkbook.Close savechanges = True End If End Sub بالتوفيق

ربما يوجد مرجع مفقود في محرر الأكواد
من قائمة tools ثم references 
ثم احذف علامة الصح بجانب المرجع المكتوب قبله missing
بالتوفيق

للأسف هذه الطريقة في الفلترة بالمعادلات المتبعة في ملفكم تجعل الملف ثقيلا جدا
لذلك يمكنك تحديد المدى الذي كنت تسحب فيه المعادلة لأسفل كله ثم حذف المعادلة منه بضغط مفتاح delete من لوحة المفاتيح مع إبقاء تحديد الخلايا ثم لصق نفس المعادلة في شريط المعادلات مع تغيير 
row($a1) إلى
row()-5  إذا كان هناك 5 صفوف فوق صف البداية
وفي النهاية الضغط على ctrl+shift+enter
بهذا نكون وضعنا معادلة واحدة في جميع الصفوف المحددة 
وهذه اسرع طريقة للفلترة بالمعادلات 
بالتوفيق

حسب فهمي للمطلوب
تم تنفيذ المعادلة على العمود الأول E
وإذا أردت تطبيقها على العمود التالي يمكنك تغيير الخلية
$E$1 في المعادلة الموجودة في الصف الثاني
بالتوفيق
mas tableau.xlsx

حسب فهمي للمطلوب يمكنك استعمال هذه المعادلة في الخلية j17 في sheet1
=TRANSPOSE('2nd'!H19:O19)  

الخطأ هو أن العمود رقم 9 فارغ ولا يتم ترحيل بيانات إليه
لذا يمكن تغيير هذا السطر
erow = sh1.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Row إلى
erow = sh1.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row بالتوفيق

يمكنك استعمال هذا الكود على افتراض أن مربع النص اسمه textbox1
Private Sub TextBox1_Enter() TextBox1.Value = "" End Sub بالتوفيق