حسين مامون

بعد ادن استادي واتراء للموضوع هذه طريقة متواضعة التنفيذ بالفورم تاريخ التقاعد.xlsm

ارفع صورة الخطأ او جرب الماكرو هكذا Sub Test1() Application.ScreenUpdating = False ActiveSheet.Unprotect Columns("A:E").Select Selection.EntireColumn.Hidden = False Columns("AD:AF").Select Selection.EntireColumn.Hidden = True Columns("P:AB").Select Selection.EntireColumn.Hidden = False Columns("AJ:AR").Select Selection.EntireColumn.Hidden = True Range("A10:A12").Select Application.ScreenUpdating = True ActiveSheet.Protect end sub

استاذ ان شاء الله تبدأ ادخال اكواد الترحيل بنفسك نبدأ بزر ترحيل شهادة تربص ما رأيك؟ لنفترض ليك شيت "شهادة تربص" الخلية D15 هي رقم التسجيل و في الفورم textbox1 iهو رقم التسجيل ونقول في حدث الزر 'شهادة تربص" Private Sub CommandButton4_Click() With Sheets("شهادة تربص") .Range("d15").Value = TextBox1.Value ' رقم التسجيل .Range("b16").Value = TextBox2.Value 'الاسم .Range("d16").Value = TextBox3.Value 'اللقب End With End Sub ونتمم ربط باقي الخلايا ب textbox المناسب

ربما يمكن الاستفادة من هذه المشاركة

استعن بهذا الفيديو .... وهذا هو ملفك وعليك أيضاً أولا تحميل نوع الخط المرفوع مع ملفك ccode39.zip باركود 2022.xlsx

وهذا الشيء لوكانت البيانات اقل من 10 Private Sub UserForm_Initialize() Dim lr1, lr Dim lr2 Dim i, k ListBox1.ColumnCount = 3 lr = Cells(Rows.Count, 2).End(3).Row If lr < 9 Then MsgBox "البيانات اقل من10": Exit Sub lr1 = Cells(Rows.Count, 2).End(3).Row - 10 lr2 = Cells(Rows.Count, 2).End(3).Row k = 0 For i = lr1 To lr2 ListBox1.AddItem ListBox1.List(k, 0) = Cells(i, 1).Value ListBox1.List(k, 1) = Cells(i, 2).Value ListBox1.List(k, 2) = Cells(i, 3).Value k = k + 1 Next i End Sub

ضع هذا الشيء في حدث الفورم Private Sub UserForm_Initialize() Dim lr1 Dim lr2 Dim i, k ListBox1.ColumnCount = 3 lr1 = Cells(Rows.Count, 2).End(3).Row - 10 lr2 = Cells(Rows.Count, 2).End(3).Row k = 0 For i = lr1 To lr2 ListBox1.AddItem ListBox1.List(k, 0) = Cells(i, 1).Value ListBox1.List(k, 1) = Cells(i, 2).Value ListBox1.List(k, 2) = Cells(i, 3).Value k = k + 1 Next i End Sub

ضع هذا الشيء في حدث تيكستبوكس1 change cheets("DATA").range("d3").value= textbox1.value وهذا ان كان ما دكرته صحيح

اخي الكريم كان عليك طلب هذا منذ المشاركة الاولى عليك بطلب جديد في مشاركة جديدة ولكن حاول اختصار طلبك في فورم نظيف بدون مشاكل. تحياتي

بعد ادن الاساتدة ربما هذا الشيء يفي بالغرض PRT.xlsm

اضف هذا السطر في الكود كما في الصورة ws2.Range("a6:d1000").Interior.Color = xlNone الصورة

بانسبة للطباعة انسخ هذا الكود الى مديول واربطه مع زر جديد في شيت الطباعة Option Explicit Sub printDOC() Dim LR LR = Cells(Rows.Count, 2).End(3).Row If MsgBox("هل تريد طباعة التقرير", vbExclamation + vbYesNo) = vbYes Then Range("a1:d" & LR).PrintPreview End If End Sub

Option Explicit Sub test() Dim lr, c, x, r, lr2 Dim ws As Worksheet Set ws = Sheets("DATA") Dim ws2 As Worksheet Set ws2 = Sheets("الطباعة") c = ws.[d3] r = 6 Application.ScreenUpdating = False With ws ws2.Range("a6:d1000").ClearContents ws2.Range("a6:d1000").Borders.LineStyle = 0 lr = .Cells(Rows.Count, 1).End(3).Row For x = 6 To lr Select Case .Cells(x, 1).Value2: Case c ws2.Range("b4").Value = .Cells(x, 1).Value ws2.Range("a" & r).Value = .Cells(x, "e").Value ws2.Range("a" & r).Offset(, 1).Value = .Cells(x, "d").Value ws2.Range("a" & r).Offset(, 2).Value = .Cells(x, "b").Value ws2.Range("a" & r).Offset(, 3).Value = .Cells(x, "c").Value ws2.Range("a" & r).Resize(, 4).Borders.LineStyle = xlDot r = r + 1 End Select Next x lr2 = ws2.Cells(Rows.Count, 1).End(3).Row + 2 ws2.Range("b" & lr2) = "اجمالي" ws2.Range("c" & lr2) = WorksheetFunction.Sum(ws2.Range("c6:c" & r - 1)) ws2.Range("d" & lr2) = WorksheetFunction.Sum(ws2.Range("d6:d" & r - 1)) If ws2.Range("c" & lr2) > ws2.Range("d" & lr2) Then ws2.Range("b" & lr2).Offset(1) = "اجمالي مدين" ws2.Range("c" & lr2).Offset(1) = ws2.Range("c" & lr2) - ws2.Range("d" & lr2) ElseIf ws2.Range("c" & lr2) < ws2.Range("d" & lr2) Then ws2.Range("b" & lr2).Offset(1) = "اجمالي دائن" ws2.Range("c" & lr2).Offset(1) = ws2.Range("d" & lr2) - ws2.Range("c" & lr2) End If '==================== ws2.Range("a" & lr2).Resize(1, 4).Interior.Color = 49407 ws2.Range("a" & lr2 + 1).Resize(1, 4).Interior.ThemeColor = xlThemeColorAccent5 With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeTop) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeBottom) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeRight) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeLeft) .LineStyle = xlDot .Weight = xlThin End With With ws2.Range("a" & lr2).Resize(2, 4).Borders(xlEdgeTop) .LineStyle = xlDot .Weight = xlThin End With '====================== ws2.Activate End With Application.ScreenUpdating = True End Sub

جرب هذا الشيء استعلام حسب ايام الشهر.xlsm

ربما يكون بالمرفق ما تريد الحسابات على عيسى 2.xlsm

لنفترض ان البيانات في العمود a1:e اولا نكتب اسم الماكرو ()sub test ثم متغير dim lr Lr = cells(rows.count,"a").end(xlup).row ثم الجزء الذي سيطبع البانات من اول صف الى اخر خلية فيها بيانات Range("a1:e"&lr).printout End sub

بعد ادن استاد سليم ربما يفيدك هذا الشيء حساب تاريخ نهاية الاجازة.xlsm

الكود تمام واصل هكذا اتمنى لك التوفيق

في حدث تيكسبوكس1 change اكتب الحالة الشرطية اولا If textbox1="" then وهنا اكتب التكستات التي تريد افراعها : مثلا "" = textbox2 وهكذا وفي الاخير انهاء الشرط: End if

جرب هذا الشيء sub PRINT_OUT Range("a1:f32").Printout end sub

بالنسبة للطلبي 2 جرب الكود التالي ضعه في Textbox1 فورم1 ادخل رقم الحساب وانقر زر انتر على لوحة المفاتيح Private Sub TextBox1_AfterUpdate() Dim ws As Worksheet: Set ws = Sheets("ورقة1") Dim lr, x lr = ws.Cells(Rows.Count, 3).End(3).Row For x = 2 To lr If TextBox1.Text = ws.Cells(x, 3).Text Then TextBox2.Value = ws.Cells(x, 4).Value TextBox3.Value = ws.Cells(x, 5).Value TextBox4.Value = ws.Cells(x, 6).Value ComboBox1.Value = ws.Cells(x, 7).Value Exit For End If Next x End Sub وهذا في Combobox1 Private Sub ComboBox1_Change() Sheets("ورقة2").Range("j8").Value = Me.ComboBox1.Value End Sub

اكتب ما قال الاستاذ سليم وغير السطر المضلل الى set return_sh = Activesheet.name

عند ادخال اي نص او قيمة في الخليتين انقر زر Entr على لوحة المفاتيح وانظر وهذا الكود في حدث شنج Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = ("$F$4") Then Shapes.Range(Array("Rectangle 3")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Target ElseIf Target.Address = ("$F$5") Then Shapes.Range(Array("TextBox 4")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Target End If End Sub ربط مربع نص بدالة.xlsm

جرب هذه الفكرة ربما تكون احسن البحث بادخال الحرف الاول ثم الثاني ثم ........... فورم بحث فى جميع بيانات الجدول.xlsm

جرب ربما يكون ما تقصد كشف حساب .xlsm