عبدالفتاح في بي اكسيل

@M.NHAKAMI
 ولكن  لماذا  كل هذه الاسطر  وعدم تنظيم  في  ارقام  الليبل ؟!
اقترح عليك  بجعل  ارقام  الليبل بشكل متتالي  حتى  تسهل  الامر  عليك ومن تم وضعها في حلقة تكرارية  ووضع الخلايا في مصفوفه 
على  اي حال  في  نهاية مدى كل خليه  ضع كلمة TEXT 
هذا مثال 
Label163.Caption = Sheets("دراسة فندق").Range("h6").Text  

اذا كنت تقصد اظهار التقويم لاختيار التاريخ عندها يمكن استخدام اداتين  date picker او  calendar .
هذه محاولة  بعد القيام بإضافة فورم التقويم والقيام ببعض التعديلات .
قم بالنقر مرتين علي خلية التاريخ وسيظهر التقويم . 
ولكن هذا يتوقف على اصدار  الاوفيس  اشك انها تعمل مع الإصدارات قبل 2016 واذا  واجهتك مشكلة  بإظهار  رسالة بعدم وجود كائن عنده  يجب تنصيبه حتى يظهر  لك .
حاليا يعمل  معي  باستخدام  بإصدار 2019
تحياتي
مطلوب تعديل.xlsm

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

جرب هذه المعادلة  مع مراعاة الفاصلة على حسب اصدار الاوفيس
=IF(ISERROR(SEARCH("-";F11));1;TRIM(RIGHT(SUBSTITUTE(F11;"-";REPT(" ";100));100)))  

ادخل  على خيارات  الوظائف  الاضافية وازل  تاشيرات الادوات  التي  لا تريدها .

@2saad
هل ممكن ان تقول  لي المتغير  i فيما  يستخدم بناء على كودك؟!!!
Private Sub CommandButton2_Click() Dim add As Integer i = Application.WorksheetFunction.CountA(Sheet54.Range("c:c")) add = Sheet54.Range("c1000").End(xlUp).row + 1 Sheet54.Cells(add, 3).Value = Me.TextBox1.Value Sheet54.Cells(add, 4).Value = Me.TextBox2.Value Sheet54.Cells(add, 5).Value = Me.TextBox3.Value Sheet54.Cells(add, 6).Value = Me.TextBox4.Value Sheet54.Cells(add, 7).Value = Me.TextBox5.Value Sheet54.Cells(add, 8).Value = Me.TextBox6.Value Sheet54.Cells(add, 9).Value = Me.TextBox7.Value Sheet54.Cells(add, 10).Value = Me.TextBox8.Value Sheet54.Cells(add, 11).Value = Me.TextBox9.Value Sheet54.Cells(add, 12).Value = Me.TextBox10.Value Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox7.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" Me.TextBox10.Value = "" MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" End Sub  
جرب  هذا  التغيير  ولكن  قبل  كل  شيء اتبع  الخطوات بعناية 
1- احدف  اي  صف  فارغ في  الجدول ( لا تجعل الجدول يحتوي على صفوف فارغة) 
2- لا داعي  للتيكست بوكس  الخاص  بالتسلسل  لانه  الكود  سيقوم بادراج صف ويقوم بترقيمها اتوماتيكيا  حينها  سيصبح عند 9 تيكست بوكس وليس 10 كما  في الكود 
3- تم  التعديل  باضافة اجراءات خاصة بكائن الجدول 
هذه محاولة قد تفيدك
Private Sub CommandButton2_Click() Dim tbl As ListObject Dim LastRow As Long Set tbl = Sheet54.ListObjects("Table14") LastRow = tbl.Range.Rows.Count With Sheet54 tbl.Range(LastRow, "B").Offset(1) = TextBox1.Value tbl.Range(LastRow, "C").Offset(1) = TextBox2.Value tbl.Range(LastRow, "D").Offset(1) = TextBox3.Value tbl.Range(LastRow, "E").Offset(1) = TextBox4.Value tbl.Range(LastRow, "F").Offset(1) = TextBox5.Value tbl.Range(LastRow, "G").Offset(1) = TextBox6.Value tbl.Range(LastRow, "H").Offset(1) = TextBox7.Value tbl.Range(LastRow, "I").Offset(1) = TextBox8.Value tbl.Range(LastRow, "J").Offset(1) = TextBox9.Value End With MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox7.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" End Sub  
 
 

اعتقد  ان هذا  الماكرو يفي  بمتطلباتك 
اكتبي  رقم  العمود   الذي  تريدينه   ان  يقوم  بترحيل  بياناته
Sub parse_data() Dim lr As Long Dim ws As Worksheet Dim vcol, i As Integer Dim icol As Long Dim myarr As Variant Dim title As String Dim titlerow As Integer Application.ScreenUpdating = False vcol = Application.InputBox(Prompt:=" اي العمود الذي تريد فرزه", title:="فلترة عمود", Default:="3", Type:=1) Set ws = ActiveSheet lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row title = "A1" titlerow = ws.Range(title).Cells(1).Row icol = ws.Columns.Count ws.Cells(1, icol) = "Unique" For i = 2 To lr On Error Resume Next If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) End If Next myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) ws.Columns(icol).Clear For i = 2 To UBound(myarr) ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" Else Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) End If ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 'Sheets(myarr(i) & "").Columns.AutoFit Next ws.AutoFilterMode = False ws.Activate Application.ScreenUpdating = True End Sub  

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

اول شيء  الورقة المشار  اليها   في  الكود  لا يطابق  مع  ما  تريده  اذا  كنت  تريدة  في  الورقة  النشطة  عند  فتح  الملف 
ثانيا  الكود  لن  يقوم  الا  بالنسخ في  الصف  الثاني  ومكرر ارقام  التيكست  بوكس 
بمعنى  اخر  الكود  فوضوي  لابعد  الحدود !!
جرب  هذا  الشيء  مع  التاكد  من  اسم  الشيت  عند  الترحيل 
Private Sub CommandButton1_Click() Dim lr As Long, SH As Worksheet Set SH = Worksheets("sheet1") lr = SH.Cells(Rows.Count, 1).End(xlUp).Row With SH .Range("A" & lr + 1) = TextBox1.Value .Range("B" & lr + 1) = TextBox2.Value .Range("C" & lr + 1) = TextBox3.Value .Range("D" & lr + 1) = TextBox4.Value .Range("E" & lr + 1) = TextBox5.Value .Range("F" & lr + 1) = TextBox6.Value .Range("G" & lr + 1) = TextBox7.Value .Range("H" & lr + 1) = TextBox8.Value End With End Sub  

@abdelfattahbadawy
جرب هذا الماكرو
Dim ct As Long, destPath As String Sub MOVE_FILES() Dim Fso As Object, Fldr As Object, f As Object ', ct As Long Dim sourcePath Dim FileInFolder As Object sourcePath = "C:\Users\Administrator\Downloads\nnnn\" 'Change path and folder name to suit destPath = "C:\Users\Administrator\Downloads\mmm\" 'Change path and folder name to suit Set Fso = CreateObject("Scripting.FileSystemObject") LoopFolder (sourcePath) Set Fldr = Fso.GetFolder(sourcePath) For Each f In Fldr.subfolders LoopFolder (f) Next f If ct > 0 Then MsgBox ct & " pdf files have been moved" Else MsgBox "No pdf files found in the source folder" End If End Sub Private Function LoopFolder(AFolder) Set Fso = CreateObject("Scripting.FileSystemObject") Set ThisFolder = Fso.GetFolder(AFolder) For Each FileInFolder In ThisFolder.Files If FileInFolder.Name Like "*.pdf*" Or FileInFolder.Name Like "*PDF*" Then ct = ct + 1 FileInFolder.Move destPath End If Next FileInFolder End Function  

ضع في  موديول عادي
Public dTime As Date Sub KillUserForm() Unload UserForm1 End Sub  
في موديول يوزرفورم
Private Sub UserForm_Initialize() CTime = Time + TimeValue("00:00:10") Application.OnTime CTime, "KillUserForm" End Sub  

كان  من  الاجدر  ان  ترفق  ملف  مادام  اقتراح @hassona229 ليس  ما  تريده  حينها ستضطر  العمل  مع  كود  معين .
لا اعلم  اذا  فهمتك  جيدا  
هذا  الماكرو  سيقوم  بالبحث  في  كل  الاوراق  عن  الخلايا  التي  تحتوي على  فاصلة  بدون  اختيار  اي  خلية 
Sub Replace_marks() Const MCOMMA = "," Const MDOT = "." Dim ws As Worksheet For Each ws In Worksheets ws.UsedRange.Replace MCOMMA, MDOT, xlPart Next ws End Sub  

مجرد تخمين
Sub kh_RngProper() Dim Cel As Range Dim ws As Worksheet For Each ws In Worksheets For Each Cel In ws.UsedRange Cel.Value = StrConv(CStr(Cel), vbProperCase) Next Next ws End Sub  

جرب هذا  الملف و لاتقم  بضغط  الملف تجنبا  لاهدار  الوقت 
منع تكرار الاسم.xls

يجب ان  تكون متوفر   عادة 
ولكن  قم  بازالة OLE automation  ثم  تحديده  ثم اغلق  الملف بعد حفظه  وافتحه  من جديد وابحث  عن  الاداة 
من  داخل محرر الاكواد من قائمة refernce>tools >OLE automation

وهذ ا  موضوع  مشابه  كنت  قد  اجبت  عليه  احد  الاعضاء  يمكنك  الاطلاع  عليه  واعلامي  ماذا  يحدث  معك .
https://www.officena.net/ib/topic/102575-كود-كليندر-يعمل-على-اوفيس-2003ولايعمل-على2013/#comment-618610
تحياتي .

ضع  هذا  الشيء  في  نهاية كودك 
Me.TextBox1.SetFocus  

اتمنى ينجح  معك  لانه  عمل  معي 
data2.xlsm

ولكن كله نفس  التاريخ ،  لماذا تحتاج  الى تحديد تاريخ ؟
احرص على ان  كل  الارقام تحتوي على Bytes   ..جرب هذه المعادلة  C50
=SUMPRODUCT(SUBSTITUTE("0"&C2:C49,"Bytes","")+0) & "Bytes"  

ولماذا لا تقول  ما  هي  مشكلتك ، هل  يوجد خطأ  ام  لا يظهر  شيء؟
ولماذا لا تشرح الية عمل برنامج  البحث  يتم عن اي  عمود , هل  علينا  ان  ندخل داخل  البرنامج ونراجع سطر  بسطر  حتى  نعلم كيف  يعلم  البرنامج؟
تذكر  دائما  نشر  التفاصيل  كاملة لموضوعك تجعل  فرصة  اجابة  الاعضاء  لك كبيرة جدا .
معظم  المواضيع ينشر  صاحبه  موضوع  دون  ان يتعب  نقسه  بوضع  تفاصيل  فقط يريد  اجابة بدون اي  تعب  لذا  ارى العديد  من  المواضيع مثل هذا الموضوع   دون  ان اقدم له  المساعدة ان استطعت .
لا ادري  اذا كنت تتحدث  عن خطا  في  هذا  السطر  وهو ما  ظهرلي  في  هذا  السطر 
isearch = Worksheets("sheet4").Range("a1").CurrentRegion.Rows.Count عندما  تريد  ان تشير  الى اسم  الصفحة  اما  ان تستخدم   Worksheets("sheet4") او  sheet4  على حسب  التسمية  الموجودة  حيث  كل  طريقة  بها  اسم  مختلف  يمكن ان تلاحظه من داخل محرر الاكواد وانت  في  كودك  اشرت الى sheet4 باستثناء  السطر  الذي  به  الخطا ، حينها تغير  الى هذا 
isearch = sheet4.Range("a1").CurrentRegion.Rows.Count  
 

اخي  الكريم  ...وكيف  سنعرف  نوعية  الخطا  اذا  انت  لم تحدده.
حقيقة  لم  استعمل  هذه  الاداة  من قبل  لكن  اذا  كنت  تقصد  هذا  الخطا "compile  erro  function not  defined"  في  هذه  الحالة  يجب  ان  تتاكد  من تقعيل  هذه  الاداة  من  خلال  قائمة  خيارات  الملف والذهاب  الى  الوظائف الاضافية adds in   ويظهر  لك  مجموعة  خيارات ابحث  عنها  وفعلها وستظهر  لك القائمة  وستجدها  وفعلها ثم  ادخل  الى محرر الاكواد  ومن قائمة tool >reference > solver  قم بتحديدها  اما  اذا  كان  خطا  اخر  فعليك  توضيح  ذلك  و  لاتضع   سؤال  عشوائي   لا  احد  يعلم  ما  هو  الخطأ . تحياتي
 

اذا  كنت  تريد  المساعدة  في  المرة  القادمة  يرجى  الاجابة  عن  الاستفسارات واخذ  ملاحظاتي  بعين  الاعتبار  .
  غير  هذا  الكود  بالكامل  وسيختفي  الخطا  انشاء  الله .
تم اضافة  هذا  الجزء  بعد  اعلان  المتغير (المشكلة  في  الخطا  في  الخلية  التي  سألتك  عنها  )
كما  ستلاحظ  اذا   كانت  هناك  بيانات  سابقة  معبئة  وكان رقم  الهوية  فارغ  سوف  يتم  مسحها  اذا كان  لا يوجد رقم  هوية ليس  من  المنطقي  بقاؤها 
If ورقة2.Cells(2, 16).Text = "#N/A" Then MsgBox "الرجاء تعبئة رقم الهوية ", vbCritical With ورقة1 Range("d5:d13", "g5:g13").ClearContents End With ورقة1.Range("E3").Select Else Private Sub CommandButton2_Click() ورقة2.Range("O2").Value = ورقة1.Range("E3").Value Dim lsearch As Integer If ورقة2.Cells(2, 16).Text = "#N/A" Then MsgBox "الرجاء تعبئة رقم الهوية ", vbCritical With ورقة1 Range("d5:d13", "g5:g13").ClearContents End With ورقة1.Range("E3").Select Else lsearch = ورقة2.Range("P2").Value ورقة1.Range("D5").Value = ورقة2.Cells(lsearch, "B").Value ورقة1.Range("D7").Value = ورقة2.Cells(lsearch, "C").Value ورقة1.Range("D9").Value = ورقة2.Cells(lsearch, "D").Value ورقة1.Range("D11").Value = ورقة2.Cells(lsearch, "E").Value ورقة1.Range("D13").Value = ورقة2.Cells(lsearch, "F").Value ورقة1.Range("G5").Value = ورقة2.Cells(lsearch, "G").Value ورقة1.Range("G7").Value = ورقة2.Cells(lsearch, "H").Value ورقة1.Range("G9").Value = ورقة2.Cells(lsearch, "I").Value ورقة1.Range("G11").Value = ورقة2.Cells(lsearch, "J").Value ورقة1.Range("G13").Value = ورقة2.Cells(lsearch, "K").Value MsgBox "تم استخراج البيانات بنجاح ", vbInformation, "رسالة تأكيد" End If End Sub  

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

تقضل اخي  الكريم  ..هذه اعادة  صياغة  الكود  (احذف  الاكواد اللي  عندك)
Private Sub ComboBox1_Change() Dim Name As String Dim sh As Worksheet Dim myrange As Range Set sh = ThisWorkbook.Worksheets("sheet1") Name = Me.ComboBox1.Value Set myrange = sh.Columns(2).Find(Name, LookIn:=xlValues, lookat:=xlWhole) If Not myrange Is Nothing Then With myrange TextBox1.Value = .Offset(, 1) TextBox2.Value = .Offset(, 2) End With End If End Sub امل  انه  تم  اصلاح  كل  مشاكلك .

@حواديتهذه محاولة يوجد  طرق  اخرى   لكان  لضيق  وقتي   اخترت  ابسط الطرق 
قم بانشاء  موديل وضع  هذا  الكود  وانظر  الى  النتيجة  اذا كان  هذا  ما  تريده 
ملاحظة : لا احبذ استخدام  اللغة  العربية في  الاكسيل  لانه  تسبب مشاكل في  الاكواد  لعدة  عوامل  وفي  المرة  القادمة اذا  اردت  اكواد عليك  ارفاق  ملف  يقبل  الاكواد مثل XLSM  
Sub test() Dim last_row As Long Dim rng, rng1 As Range last_row = ThisWorkbook.Worksheets("الاكواد").Cells(Rows.Count, 1).End(xlUp).Row Set rng = Range("C3:C" & last_row) Set rng1 = Range("D3:D" & last_row) rng.Formula = "=SUMIF(اليوميه!$A$1:$A$1048575,A3,اليوميه!$C$1:$C$1048575)" rng1.Formula = "=SUMIF(اليوميه!$A$1:$A$1048575,A3,اليوميه!$D$1:$D$1048575)" rng.Value = rng.Value rng1.Value = rng1.Value End Sub تحياتي .

مشكلته  كانت بسيطة  لكن  مؤثرة ومحيرة بعض  الشيء  
اسم  الورقة الموجودة  في  الكود   ليست  نفسه كما  في  داخل  الورقة . من  الوهلة  الاولى  عند  النظر  اليها  تعتقد  انها  نفس  الشيء( لتجنب هكذا مشاكل  استخدم  خاصية   copy & paste) 
الشي  الثاني  يجب  ايضا  ان تشير   للورقة  لهذا  السطر  ايضا
If Sheet1.Cells(i, 4) - Date >= 0 And Sheet1.Cells(i, 4) - Date <= 30 Then  اتمنى  ان  تكون  الامور  جيدة الان .
تذكير بتاريخ انتهاء العقود.xlsm