حسين مامون

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

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

لم اجد في اي ملف بمشاركتك في هذا الشيت الذي اشرت اليه وما علاقة هذا الكود باضافة شيتات اخرى؟ ! يستحسن رفع ملف نموذجي مع شرح ما تريد بالتفصسل تحياتي

بالنسبة للترقيم التلقائي جرب المرفق المكتبه 1 (2).xlsm

اولا : كما قلت لك في مشاركة سابقة كود الدخول في الفورم له علاقة ب sheet3 واي ملف ليس فيه sheet3 ونفس البيانات في ("b1:c1") فلن يعمل معك تانيا: اي ملف اكسيل تريد تطبيق عليه الفورم تأكد من امتداده هل هو xlsm

يمكن ان تكون شيت لها علاقة باكواد الفورم غير موجودة في ملفك

ارفع الملف الذي نقلت اليه الفورم

اتبع الخطوات في الصور بمشاركتي السابقة

اولا افتح الملف لي فيه الفورم واذهب الى قائمة développeur ثم زر الماوس الايمن على الفورم كما في الصورة ثم اختر éxporter un fichier وفي النافذة المفتوحة اختر مكان حفظ الفورم وانقر enregestre اغلق الملف المفتوح واذهب الى الملف المراد نقل الفورم اليه وانقر قائمة développeur ثم زر الماوس الايمن واختر كما في الصورة وفي النافذة المفتوحة اختر الفورم وانقر على .... كما في الصورة

جرب المحاولة في المرفق لعلها ما تريد 44.xlsm

جرب تسمية الشيتات داخل الكود كهذا الجزء If UserForm1.TextBox1.Value = "admin" And UserForm1.TextBox2.Value = 2020 Then Sheets("الرئيسية").Activate End If وهذا ايضا If UserForm1.TextBox1.Value = "ali" And UserForm1.TextBox2.Value = 456 Then Sheets("فاتورة").Select End If

جرب المرفق fik.xlsm

جرب هذا الكود ولكن يجب ان تكون مسميات الشيتات كما في العمود (i) Sub Envoier_donner() Dim sh As Worksheet Dim ws As Worksheet Set ws = Sheets("التقرير") Dim lr1, lr2, x, x2 Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets lr1 = ws.Cells(Rows.Count, 2).End(3).Row For x = 11 To lr1 If ws.Cells(x, "i").Text = sh.Name Then lr2 = sh.Cells(Rows.Count, 2).End(3).Row + 1 sh.Range("b" & lr2).Resize(1, 12).Value = ws.Cells(x, 2).Resize(1, 12).Value End If Next x Next sh Application.ScreenUpdating = True End Sub fik.xlsm

بوركت اخي و الحمد لله ان تم الامر على خير

جرب المرفق 100.xlsm

استاد حسن البدوي لا اعرق لماذا تعيد نفس طلب مشاركة سابقة علما انني اجبتك في تلك المشاركة ولم تبدي اي رأي ، كان بالامكان طلب تعديل نفس المشاركة وتجنب اهدار وقتك و وقت الاعضاء عموما اليك المرفق اولا ادخل اسم العميل ثم البيانات الاخرى ثانيا اضغط زر حفظ ملاحظة : لا يمكن تكرار نفس العميل اكثر من مرة تحياتي الفاتورة الرئيسيه (3).xlsm

جرب المرفق Sub serchsheet() Dim sh As Worksheet Dim rng As Range Set rng = Sheets("ÊÚÏíá_ÓÚÑ_ÇáÚãíá").Range("G2") Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name = rng.Text Then sh.Visible = True sh.Activate Exit For End If Next sh Application.ScreenUpdating = True End Sub الفاتورة الرئيسية.xlsm

جرب هذا الماكرو لعله يفي بالغرض Sub TRANS() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim lr1, lr2 Set ws1 = Sheets("جدول المبيعات") Set ws2 = Sheets("قائمة المبيعات") lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row lr2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1 ws1.Range("b6:b" & lr1).Copy ws2.Range("b" & lr2) ws1.Range("c6:c" & lr1).Copy ws2.Range("e" & lr2) End Sub ترحيل.xlsm

جرب المرفق الفاتورة الرئيسيه (3).xlsm

السلام عليكم ربما يكون ما تريد في اضافة هذا السطر للكود بعد الحلقة التكرارية If FS.Range("b6").Text = TS.Cells(er2, 1).Text Then MsgBox "هذا الاسم مكرر": Exit Sub

وعليكم السلام ورحمة الله الاخ محمد عبد السلام ما المقصود بانشاء شيت2 وترحيل نفس البيانات لي في شيت1 هل ممكن توضيح ؟ اضافة اشياء اخرى للكود لا نحتاجها قد يثقل عمل الكود اضف هذه السطور اسفل الجزء الذي يرحل الى شيت1 Dim wss2 As Worksheet Set wss2 = wx.Sheets("sheet2") Dim lr2 lr2 = wss2.Range("a" & Rows.Count).End(xlUp).row + 1 If ws.[f5].Text = "اجل" Then wss2.Range("a" & lr2).Value = Nam wss2.Range("a" & lr2).Font.Color = 255 wss2.Range("b" & lr2).Value = "اجل" Else: wss2.Range("a" & lr2).Value = Nam wss2.Range("b" & lr2).Value = "نقدي" End If

جرب المرفق لعله يفي بالغرض المصنف1( (1).xlsm

عليكم السلام ورحمة الله اخي الكريم اليك هذا العمل حسب ما فهمت في مشاركتك Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim LR As Long Dim rng Dim tot Set tot = Range("b10") Set rng = Range("b2:b9") If Not Intersect(Target, rng) Is Nothing Then Range("b10").Formula = "=SUM(B2:B9)" If Range("b10") > 100 Then MsgBox "خطأ في الادخال" Target = "" Target.Activate End If End If End Sub test.xlsm

جرب المرفق شهر10.xlsm

عليكم السلام جرب هذا التعديل ولكن مذا عن استعراص البيانات في الفورم ؟ سيأتر هذا عن ذلك وستضطر لتعديل الفورم Private Sub CommandButton1_Click() Dim ws As Worksheet Set ws = ActiveWorkbook.Sheets("invoice") Dim wss As Worksheet Set wss = ActiveWorkbook.Sheets("Sheet1") Dim DT Dim Nam Dim lr As Long Application.ScreenUpdating = False Application.EnableEvents = False lr = wss.Range("a" & Rows.Count).End(xlUp).Row + 1 DT = ws.Range("e5") & Format(Now(), " ss - mm - hh - yyyy - mm - dd ") With ws Application.DisplayAlerts = False Nam = .Range("e5") & " " & Format(Now(), " ss - mm - hh - yyyy - mm - dd ") ThisWorkbook.SaveCopyAs Filename:="D:\back\Backup\" & Nam & ".xlsm" ' '========================================= End With If ws.Range("F5").Value = "نقدي" Then Else: wss.Range("a" & lr).Value = ws.Range("e5") wss.Range("b" & lr).Value = Format(Now(), " ss - mm - hh - yyyy - mm - dd ") wss.Range("C" & lr).Value = "اجل" End If If ws.[f5].Text = "اجل" Then Else: wss.Range("a" & lr).Value = ws.Range("e5") wss.Range("b" & lr).Value = Format(Now(), " ss - mm - hh - yyyy - mm - dd ") wss.Range("C" & lr).Value = "نقدي" End If Application.ScreenUpdating = True Application.EnableEvents = True End Sub