نجوم المشاركات

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Dim tmps As Object, cell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If tmps Is Nothing Then Set tmps = CreateObject("Scripting.Dictionary") If Target.Cells.Count > 1 Then Exit Sub For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing Then tmps(cell.Address) = cell.Value Next cell ExitHandler: Exit Sub ClearApp: Set tmps = Nothing Resume ExitHandler End Sub Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Or tmps Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing And tmps.exists(cell.Address) Then If IsNumeric(cell.Value) Then cell.Value = tmps(cell.Address) + cell.Value Else MsgBox cell.Address & " : " & "تم إدخال قيمة غير صالحة في الخلية ", vbExclamation End If End If Next cell ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub جمع الخلية v3.xlsb

في حدث Before Update أو After Update الخاص بالحقل ضع هذا السطر Me.FADD = LTrim(Me.FADD)

وعليكم السلام ورحمة الله تفضل جمع الخلية.xlsm

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

لا أدري ما تقصد فتحت ملفك ووجدت خلايا بالأزرق وخلايا بالأحمر الكود يعمل في الأزرق ولا يعمل في الأحمر أرجو التوضيح أكثر

مشاركة مع أخي الأستاذ @ناقل ، هذه مشاركتي بحيث لو كانت المسافات بداية أو نهاية النص ، وليس فقط بداية النص :- Me.FADD = Trim(Me.FADD)

لاحظ الصورة نتمنى يكون المطلوب test6325.rar

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

كما ذكر اخي @Foksh صورة او ورقة اكسل وتكتب كل العناوين فيها وجعلها بدل مربعات النص او ورقة وورد

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

تفضل ورقة ارسال عن طريق الواتس اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا من طلبك لاكن حاول تجربة هدا Option Explicit Private Const n As Long = 25 Private Const rHeight As Double = 20 Private Const tmps As Integer = 4 Private Const Col As String = "B" Sub PrintWS() Dim lr As Long, i As Long Dim lastCol As Long, OnRng As Range Dim CrWS As Worksheet Dim ColNum As Long Set CrWS = Sheets("Data") Application.ScreenUpdating = False CrWS.ResetAllPageBreaks Application.ActiveWindow.View = xlPageBreakPreview ColNum = CrWS.Range(Col & "1").Column lr = CrWS.Range(Col & CrWS.Rows.count).End(xlUp).Row CrWS.Rows("5:" & lr).RowHeight = rHeight If lr > tmps + n Then For i = tmps + n + 1 To lr Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(tmps, CrWS.Columns.count).End(xlToLeft).Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, ColNum), CrWS.Cells(lr, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) CrWS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 With CrWS.PageSetup .Orientation = xlPortrait: .PaperSize = xlPaperA4 .FitToPagesWide = 1: .FitToPagesTall = False End With Application.ScreenUpdating = True End Sub Test V1.xlsb