شوقي ربيع

بكل بساطة اعكس العملية
Dim LastRow As Long LastRow = ThisWorkbook.Sheets("xx").Range("g1").End(xlDown).Row LastRow = LastRow + 1  

جرب هذا
Archivé Mobile V 1.001(1).rar

من خصائص اليوزر فورم ابحث عن RightToLeft و اجعلها True
او استبدل الكود السابق بهذا
Private Sub UserForm_Activate() Me.RightToLeft = True With Me.ListBox1 .ColumnCount = 4 .List = Range("D5:G14").Value End With End Sub

السلام عليكم
حسب فهي لطلبك هو انك لا تريد تكرار الاصناف في الفاتورة و هناك طريقتين لتنفيذ المطلوب
الاولى باستخدام الطريقة التقليدية  رسالة تنبيه و كود يمنع المستخدم من تكرار الصنف
الثانية هي ما ساقدمه لك
ببساطة الافكرة تعتمد على مصفوفتين الاولى تحمل جميع الاصناف المخزنة في الداتا و الثانية من اجل تصفية وحذف الاصناف التي استعملت بالفعل ثم نقوم باعادت تحميل البيانات المفلترة من المصفوفة الثانية الى المصفوفة الاولى
؟؟؟؟ قد تقول لما ذا هته الفة لماذا لا تفلتر في المصفوفة الاولى في حد ذاتها
جوابي ببساطة شخصيا لا اعرف طريقة لحذف عنصر معين من المصفوة الذي اعرفه هو مسح المسفوفة بالكامل وان كان هناك من الاعضاء المحترمين في المنتدى يعلمون الطريقة فياريت يعلمني بالطريقة
نعود الى موضوعنا
اولا عرف مصفوفتين ول يكن تعريفهما على عامت الفورم وليس على حدث او SUB ما
Dim Arr1(), Arr2() ثانيا نحتاج الى كود يملئ لنا المصفوفة الاولى من قاعدة البيانات وفي نفس الوقت يملئ قوائم الاصناف في الفورم
Sub Listcmd() Dim ws As Worksheet Dim Lrw As Long Set ws = ThisWorkbook.Sheets("setup") Lrw = ws.Range("A" & Rows.Count).End(xlUp).Row Arr1 = Application.Transpose(ws.Range("B2:B" & Lrw).Value) For i = 8 To 13 Me("ComboBox" & i).List = Arr1 Next End Sub اما هذا الكود
Sub ListArr(cmd As String) Dim sTe As String: sTe = Me(cmd).Text Dim ii As Long, e As Long: e = 0 For ii = LBound(Arr1) To UBound(Arr1) If CStr(Arr1(ii)) <> sTe Then e = e + 1: ReDim Preserve Arr2(e) Arr2(e) = Arr1(ii) End If Next ii ReDim Arr1(e): Arr1 = Arr2 End Sub يقوم بمسح الصنف الذي ياخذه المتغير cmd من المصفوفة
اخيرا كود به حلقة تكرارية تدور حول كل الكمبوبوكس الخاصة بالاصناف لـاخذ القيمة التي تحملها وتذهب بها الى الكود السابق لكي يحذف الصنف من القائمة الاصناف
ثم يعيد تعبئة الكمبوبوكس بالاصناف الغير مستعملة فقط
Sub FList() Listcmd For i = 8 To 13 If Me("ComboBox" & i) <> "" Then ListArr Me("ComboBox" & i).Name Next For i = 8 To 13 Me("ComboBox" & i).List = Arr1 Next End Sub ملاحضة
الكود يقوم بارجاع الصنف المحذوف في حالة تغيره يعني لو استعملت الصنف سيحذف من القوائم لاكن لو غيرت الصنف الى صنف اخر سيحذف الصنف الجديد من القائمة ويستبدل مكانه الصنف السابق له
ارجو ان اكون قد وفق ولو قليل في شرح الفكرة  وان يكون فيها افادة للجميع
تحياتي للجميع
فاتورة مبيعات.rar

السلام عليكم
تم استخدام كمبوبوكس بدلا من التكست بوكس للبحث
تم اضافة قموس ثاني لملىء الكمبوبوكس الخاصة بالتاريخ بدون تكرار
If Not IsEmpty(keyArray(i, 1)) Then sDic2(keyArray(i, 1)) = "" If IsArray(keyArray) Then ComboBox3.List = sDic2.keys: ComboBox4.List = sDic2.keys وهذا الكود المستعمل في البحث ايضا يعتمد على المصفوفات
يقوم بملىء اليست بوكس حسب الفترة التي تختارها مع اعطاء مجموع تلك الفترة في تكستبوكس المجموع
If ComboBox3 = "" Then MsgBox "فضلا اختر تاريخ بداية البحث أولا": Exit Sub Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("data") If IsDate(ComboBox3) Then a = CDate(Me.ComboBox3.Value) Else Exit Sub If IsDate(ComboBox4) Then b = CDate(Me.ComboBox4.Value) Else Exit Sub e = 0 Dim x As Integer: x = 0 For i = LBound(keyArray) To UBound(keyArray)         If a <= CDate(keyArray(i, 1)) And b >= CDate(keyArray(i, 1)) Then         e = e + 1: ReDim Preserve keyArray2(1 To 4, 1 To e)                 keyArray2(1, e) = keyArray(i, 1)                 keyArray2(2, e) = keyArray(i, 4)                 keyArray2(3, e) = keyArray(i, 5)                 keyArray2(4, e) = keyArray(i, 7)                 x = x + Val(keyArray(i, 7))         End If                  If e > 0 Then             If UBound(keyArray2, 2) > 1 Then                 Me.ListBox1.List = Application.Transpose(keyArray2)                 Else                 Dim c(1 To 1, 1 To 4)                 c(1, 1) = keyArray2(1, 1)                 c(1, 2) = keyArray2(2, 1)                 c(1, 3) = keyArray2(3, 1)                 c(1, 4) = keyArray2(4, 1)                 Me.ListBox1.List = c             End If         Else                 Me.ListBox1.Clear         End If Next Me.TextBox1.Value = x تحياتي للجميع
كود البحث بين تاريخين.rar

السلام عليكم
اولا من الافضل عدم توجيه طلباتك الى اعضاء معينين لان هذا ممكن يمنع من يريد المساعدة من مساعدتك وايضا من  الممكن ان من طلبت منهم المساعدة  يكونو غير متوفرين
وهذا الحل لملفك
Dim lLrw1 As Long, lLrw2 As Long If TextBox1 = "" Then Exit Sub Dim b As Long: b = Me.TextBox1.Value For Each ws In ThisWorkbook.Sheets lLrw1 = ws.Cells(1, "c").End(xlDown).Row + 1 lLrw2 = ws.Cells(Rows.Count, "c").End(xlUp).Row Dim i As Long: For i = lLrw1 To lLrw2 ws.Range("B" & i) = b b = b + 1 Next Next هذا الكود يعمل على كافت الشيتات الموجودة في الملف
فقط حدد رقم البداية في التكست بوكس واضغط الزر
 
الترقيم الالي للخلايا عن طريق تاكس بوكس في الفورم.rar

السلام عليكم
لتعبئة الكبوبوكس باسماء الشيتات الموجودة في الملف
Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets Me.ComboBox1.AddItem ws.Name Me.ComboBox2.AddItem ws.Name Next لتسجيل بيانات جديدة على حسب الشيت المختار من الكمبوبوكس
Dim ws As Worksheet If Me.ComboBox1 = "" Then Exit Sub Dim sName As String: sName = Me.ComboBox1.Value Set ws = ThisWorkbook.Sheets(sName) Dim iRow As Long: iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 Dim i As Byte If Trim(Me.TextBox1.Value) = "" Then Me.TextBox1.SetFocus MsgBox "ÑÌÇÁ ÇãáÇÁ ßá ÇáÎÇäÇÊ ÇáÎÇÕÉ ÈÈíÇäÇÊ ÇáãæÙÝ", vbOKOnly, "ÊÓÌíá ãæÙÝ" Exit Sub End If For i = 1 To 4 ws.Cells(iRow, i).Value = Me("TextBox" & i).Value Me("TextBox" & i).Value = "" Next كود البحث عبر لقب الطالب
d = UCase(Me.TextBox5) & "*" e = 0 On Error GoTo Err 1 For i = LBound(keyArray) To UBound(keyArray) If UCase(keyArray(i, 2)) Like d Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 2) itemArray(3, e) = keyArray(i, 3) itemArray(4, e) = keyArray(i, 4) End If Next i If e > 0 Then If UBound(itemArray, 2) > 1 Then Me.ListBox1.List = Application.Transpose(itemArray) Else Dim c(1 To 1, 1 To 4) c(1, 1) = itemArray(1, 1) c(1, 2) = itemArray(2, 1) c(1, 3) = itemArray(3, 1) c(1, 4) = itemArray(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If Exit Sub Err: Dim ws As Worksheet Dim sName As String: sName = Me.ComboBox2.Value Set ws = ThisWorkbook.Sheets(sName) Dim iRow As Long: iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 keyArray = ws.Range("A3:B" & lrw).Value GoTo 1 كود التعديل على البايانات
Dim iRow As Long: iRow = Me.TextBox6.Value + 2 Dim ws As Worksheet Dim sName As String: sName = Me.ComboBox2.Value Set ws = ThisWorkbook.Sheets(sName) ws.Cells(iRow, 1).Value = TextBox6.Value ws.Cells(iRow, 2).Value = TextBox7.Value ws.Cells(iRow, 3).Value = TextBox8.Value ws.Cells(iRow, 4).Value = TextBox9.Value تحياتي للجميع
 
كتابة قوائم الطلبة من خلال فورم واحد.rar

السلام عليكم
Dim ws As Worksheet Dim sPath As String متغيرين لاول لتحديد الشيت الذي سنعمل عليه
الثاني من اجل مسار الملف الخاص بنا وكوده يكون
sPath = ThisWorkbook.Path & "\Image\" اما هذا الكود لتعبئة الكمبوبوكس ذات عمودين من شيت الداتا
With Me.ComboBox1 .List = ws.Range("A2:B11").Value .ColumnCount = 2 End With هذا الكود لعرض الصورة في الفورم على حسب ما نختاره من كمبوبوكس
On Error GoTo ErrHandler: Me.Image1.Picture = LoadPicture(sPath & Me.ComboBox1.Text & ".jpg") Exit Sub ErrHandler: Me.Image1.Picture = LoadPicture(sPath & "AucuneImage.jpg") Resume Next هذا السطر
On Error GoTo ErrHandler معناه عندما يكون هناك خطاء ينتقل تنفيذ الكود الى ErrHandler
وفائدته هي انه عندما لا تكون هناك صورة في ملف الصور تحمل رقم الموضف الفيوجل يعطي خطاء
لذا نتخطاه بالكود السابق لاكن مع تنفيذ اجراء وهو الاجراء المتمثل في الجزء
Me.Image1.Picture = LoadPicture(sPath & "AucuneImage.jpg") حيث AucuneImage هو اسم صورة محفوضة مسبقا في ملف الصورة تدل على عدم وجود صورة لذلك الموضف
هذا الكود المستعمل لفتح نافذت الملفات لنختار منها الصورة مع شرط اضهار الصور فقط ذات الامتدادات gif jpg jpeg وهي الامتدادات التي تتوافق مع الفيوجل
وهو الذي تبحث عنه
Dim sFilter As String Dim vaFile As Variant sFilter = "Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp," & _ "Old Files (*Old) ,*.old," & _ "All Files (*.*) ,*.*" vaFile = Application.GetOpenFilename(FileFilter:=sFilter, _ FilterIndex:=1, _ Title:="ÇÎÊÑ ÕæÑÉ", _ MultiSelect:=False) If vaFile <> False Then Me.Image1.Picture = LoadPicture(vaFile) End If الاسطر
If vaFile <> False Then Me.Image1.Picture = LoadPicture(vaFile) End If من الكود السابق معناها هو انه عندما المستعمل يختار صورة يتم عرضها في الفورم
لحفظ الصورة المحملة على الفورم في المجلد الخاص بالصور برقم الموضف  لدينا استخدمنا الكود
SavePicture Me.Image1.Picture, sPath & Me.ComboBox1.Text & ".jpg" اما للحذف استخدمنا
Me.Image1.Picture = LoadPicture(sPath & "AucuneImage.jpg") في حقيقة الامر لا يتم حذف الصورة بل يتم استبدالها بالصورة التي تكلمنا عنها في الاول التي تعني لا يوجد صورة فلهذا الموضف
 

 
لاتنسى فك الضغط عن ملف الاكسل و ملف الصور ووضعهما في مكان واحد ليشتغل الكود ولا يعطي خطاء
تحياتي للجميع
FrmImageTaste.rar

السلام عليكم
2015._2.zip

السلام عليكم
فرضا ان lastColumn =50
فالنتيجة الحتمية ل
Range("a2") & lastColumn هي
Range("a2") 50 ماهذا
لا تعني شيئ اذا الفيوجل يعتبرها خطاء
اما لو كتبنا
Range ("a2" & lastColumn) النتيجة تكون
Range ("a250") هذا صحيح لاكنه ليس الذي تريده اليس كذالك لانه عندما نرجع الى الصيغة العامة للكود
If Not Intersect(Target, Range("a2" & lastColumn)) Is Nothing Then والذي معناه انه اذا حدث اي تحديد او تغير في المدى الذي اخترته والذي وجدنا نتيجته
Range ("a250") منه النتيجة الحتمية تكون
الكود يشتغل فقط عند تحديد او حدوث تغير في الخلية a250
اما سؤالك بخصوص الفرق بين
If Not Intersect(Target, Range("a2:g" & lastColumn)) Is Nothing Then وبين
If Not Intersect(Target, Range("a2:g2")) Is Nothing Then ببساطة هو انه مثل ماقنا في الاول ستكون نتيجة
الكود الاول سيطبق على المدى
Range("a2:g50" بافترضنا انا lastColumn =50 وهو المطلوب والصحيح
اما الكود الثاني فالمدى واضحRange("a2:g2")
ولك الحكم
ارجو ان يكون قد تم التوضويح بشكل مفهوم
تحياتي للجميع

تفضل هذا الحل ليكون الادخال ديناميكي
Dim X() Dim R As Long, RR As Long Dim C As Integer Dim sText As String: sText = Me.ComboBox1.Text & " " & Me.ComboBox2.Text With ListBox1 For R = 0 To .ListCount - 1 RR = RR + 1 ReDim Preserve X(1 To 4, 1 To RR) For C = 1 To 4 If C = 2 Then X(C, RR) = sText Else X(C, RR) = .List(R, C - 1) Next Next End With ListBox1.Column = X Erase X (أستاذي القدير لم أفهم ما قصدته)
الامر بسيط ان كنت تفهم المصفوفات
المصفوفة عبارة عن جدول لاكن ليس في الشيت انما في ذاكرة الفيوجل
ما قمت به هو اني حملت محتولى اليست بوكس الى مصفوفة دينامكية علما انه يمكنا التحكم في حجم المصفوفة الديناميكية كما نشاء  .... لازمها درس طويل
شاهد هذا الدرس للعلامة الاستاذ عبد الله باقشير لكي تكون عندك فكرة عن المصفوفات
http://www.officena.net/ib/index.php?showtopic=42397
http://www.officena.net/ib/index.php?showtopic=42584
المهم بعد تحميل محتوى اليست بوكس الى المصفوفة مع ادخال البيانات التي نريد اذخالها و الى المكان او الخلية التي نريدها بكل بساطة نعيد ملئ اليست بوكس هذه المرة بمحتو المصفوفة التي عملناها فقط
ارجو ان تكون الفكرة قد وصلت
تحياتي للجميع

السلام عليكم
جرب هذا
Private Sub ComboBox1_Change() Dim i As Byte: i = Me.ComboBox1.ListIndex + 1 Me.TextFind2.Visible = False Me.TextFind1.Visible = False Me.Controls("TextFind" & i).Visible = True End Sub Private Sub ComboBox2_Change() Dim i As Byte: i = Me.ComboBox2.ListIndex + 1 Me.TextFind2.Visible = False Me.TextFind1.Visible = False Me.Controls("TextFind" & i).Visible = True End Sub

السلام عليكم
الشكر موصول للاخ ibn_egypt
وهذا كود مشابه لما تفضل به مع بعض التعديلات
Private Sub UserForm_Initialize() Dim wSh As Worksheet: Set wSh = Sheet2 Dim iLrw As Long: iLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row Dim iI As Integer Dim sTex As String For iI = 1 To iLrw If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI) Next HTML sTex, 4, 5 End Sub Private Sub HTML(sTexte As String, iSize As Integer, iScrollAmount As Integer) Me.WebBrowser1.Navigate _ "about:<html><body BGCOLOR ='' scroll='no'><font color= #00000 " & _ " size=" & iSize & " face='Arial'><marquee direction=right ; font-size: 14pt;" & _ " color: white; border-style: ridge; border-color: scrollAmount=" & iScrollAmount & ">" & sTexte & "</marquee></font></body></html>" End Sub ينسخ الكود كما هو في الفورم اما السطر HTML sTex, 4, 5 فيعني على التوالي مايلي
 النص, حجم الخط, سرعة التحرك اي انه يمكنك التحكم في الخصائص التي سبقة من هذا الكود فقط
WebBrowser.rar
وهذا حل اخر عن طريق textbox
Const cVitesse As Currency = 0.01 Dim bStart As Boolean Sub MovBar() Do While bStart timer_avant = Timer Do While Timer < timer_avant + cVitesse DoEvents Loop sMove Loop End Sub Sub sMove() Dim iWidth As Integer: iWidth = Me.TextBox1.Width Dim iI As Integer For iI = 1 To iWidth timer_avant = Timer Do While Timer < timer_avant + cVitesse DoEvents Loop Me.TextBox1.Left = -iWidth + iI Next End Sub Private Sub UserForm_Activate() bStart = True MovBar End Sub Private Sub UserForm_Initialize() Dim wSh As Worksheet: Set wSh = Sheet2 Dim iLrw As Long: iLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row Dim iI As Integer Dim sTex As String For iI = 1 To iLrw If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI) Next Me.TextBox1 = sTex With Me.TextBox1 .AutoSize = True .BackStyle = 0 .SpecialEffect = 0 End With End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) bStart = False End End Sub textbox.rar
تحياتي للجميع

السلام عليكم
بنسبة لمحرر الاكواد والفورمة في اوفيس 2013 هي هي مفيش اي اضافات
التغيرات الحاصلة اغلبها ع الاكسل او الشيتات ان صح التعبير برغم من انها ليست مختلفة كثيرا على 2010 حسب ما شفت احسن حاجة فيه هي خدمة الدريف او مشاركة الملفات

السلام عليكم
بالفعل كما قال اخي حمادة ان الكود المستعمل لأضهار الساعة هو المتسبب في المشكلة
 
لكنني أفضل استعمل الحلقة Do عن الحلقة for لأنها اسرع في التنفيذ و ايضا لا تحتاج بداية ونهاية فقط تحتاج الى شرط
المهم جرب هذا الكود
Private Sub UserForm_Activate() Time True End Sub Sub Time(Start As Boolean) Dim Secondes, N Secondes = 1# Do While Start N = Now Me.CLOCK.Caption = Format(N, "h:mm:ss AM/PM") DoEvents Loop End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Time False End End Sub تحياتي

السلام عليكم
تما هو ذاك لاضافة ورقة اخرى
وهدا كود اخر يعمل على جميع اوراق الملف وينقلها الى الاوراق المقابلة لها في الملف الجديد
اذا اردت تحديد الاوراق التي سترحل كل ما عليك ضبط طول الحلقة التكرارية
Sub Test() Dim Wkb1 As Workbook, Wkb2 As Workbook Dim wsh As Worksheet Dim i As Byte Set Wkb1 = ActiveWorkbook Workbooks.Add Set Wkb2 = ActiveWorkbook For i = 1 To Wkb1.Worksheets.Count Set wsh = Wkb1.Worksheets(i) Wkb2.Worksheets(i).Range(wsh.Range("A3:A15").Address).Value = wsh.Range("A3:A15").Value Next End Sub

السلام عليكم
انضر المرفق
 
مانفست كلابشة time.rar

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

السلام عليكم
ضع هذا الكود في زر الطباعة
Dim Sh1 As Worksheet Dim Sh2 As Worksheet Set Sh1 = ActiveWorkbook.Sheets("2003") Set Sh2 = ActiveWorkbook.Sheets("ØÈÇÚÉ") Sh2.Range("B20") = Sh1.Range("H3") Sh2.Range("E22") = Sh1.Range("I3")

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

السلام عليكم
هذا المرفق به الكود السابق من اجل حفظ الملف على شكل PDF في  المسار المدرج في الكود
مع اضافة كود ارسال الملف المحفوظ عبر البريد الالكتروني بواسطة Outlook
فونكسيو استدعاء Outlook
Function OutlMail_PDF(FileNamePDF As String, StrTo As String, StrSubject As String, StrBody As String, Send As Boolean) Dim OutApp As Object Dim OutMail As Object Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = StrTo .CC = "" .BCC = "" .Subject = StrSubject .Body = StrBody .Attachments.Add FileNamePDF If Send = True Then .Send Else .Display End If End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing End Function وهذا كود الحفظ والارسال معا
Sub PDF_ALL() Dim MyName As String MyName = "D:\MR_" & Format(Date + 1, "dd-mm-yyyy") & ".pdf" Range("C45").Select Sheets(Array("A", "B", "C", "D")).Select Sheets("A").Activate MyMsg = MsgBox("هل انت متاكد من اتمام عمليه الحفظ", 4, "تنبيه") If MyMsg = 6 Then ChDir "D:" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ MyName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ True OutlMail_PDF MyName, "***@example", "موضوع الرسالة", _ vbNewLine & "مع تحيات اخوكم في الله شوقي ربيع", False Else MsgBox "لم يتم الحفظ" End If End Sub ملاضة يمكنك ملئ محتوى الرسالة مباشرتا بتعديل عبارة (مع تحيات اخوكم شوقي ربيع) من محرر الاكواد
ارجو ان يكون هذا هو مطلبك
تحياتي للجميع
SavePDF and Send by mail.rar

السلام عليكم
هذه ابسط   وافضل اكواد ممكنة لفعل ذالك
توضع في حدثKeyPress لتاكست بوكس
 
1 لجعل التكست  بوكس لاتقبل الا الارقام
If ChrW(KeyAscii) Like "[!0-9]" Then KeyAscii = 0  2 لجعل التاكست بوكس لاتقبل الا الحرف الانجليزية الصغيرة
If ChrW(KeyAscii) Like "[!a-z]" Then KeyAscii = 0 3 لجعل التاكستبوكس  بوكس لاتقبل الا الحروف الانجليزية الكبيرة
If ChrW(KeyAscii) Like "[!A-Z]" Then KeyAscii = 0 4 لجعل التكستبوكس تقبل الا الحروف الانجليزية الصغيرة والكبيرة معا
If ChrW(KeyAscii) Like "[!A-z]" Then KeyAscii = 0 5 لجعل التكست بوكس لا تقبل الا الحروف العربية
If ChrW(KeyAscii) Like "[!أ-ي]" Then KeyAscii = 0 وهذا الملف مطبق عليه هته الاكواد
ارجوا انيفيدك ويفيد جميع الاعضاء
 
مثال توضيحي.rar

وهذا كود ثاني اكثر سرعة واختصار 
Sub test2() Dim sh As Worksheet Dim Lr As Long For i = 1 To 4 Set sh = ThisWorkbook.Sheets("shop" & i) Lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & Lr) = Date sh.Range("B" & Lr) = Feuil1.Range("B" & i + 6) sh.Range("C" & Lr) = Feuil1.Range("C" & i + 6) sh.Range("D" & Lr) = Feuil1.Range("D" & i + 6) Feuil1.Range("B" & i + 6) = "" Feuil1.Range("C" & i + 6) = "" Feuil1.Range("D" & i + 6) = "" Next End Sub

أعتذر لعدم ملاحظتي ان الملف فارغ
تفضل المرفق
 
rabie.rar