البحث في الموقع

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

السلام عليكم إخواني بهذا الصرح العظيم أرجو مساعدتي في اضافة خيار الكل ضمن القائمة المنسدلة للمدارس في نموذج FROM TABLE10 ( بشاشة القوائم )لكي استفيد منه في طباعة قوائم المدارسة بأعداد الطلاب المسجلين بالمدارسة دفعة واحدة بدلا من اختيار مدرسة مدرسة مثال بعد اضافة خيار الكل بقائمة المدارس ---- عند اختيار السنة الدراسية الحالية 2000 /2001 ثم الذهاب لاختيار من القائمة المنسدلة (الكــــــل) يتم طباعة قوائم المدارس التي بها اسماء الطلبة الملتحقة بها بحيث يكون كل قائمة مدرسة على حدا وعند اختيار مدرسة واحدة يتم طباعة فقط قائمة اسماء الطلاب بهذه المدرسة فقط ( وهذا هو الاجراء الحالي ارجو الاحتفاظ به ) شكرا مقدما برنامج العقود - 4.accdb

السلام عليكم الملف المرفق يحتوي على ثلاثة شيتات يهمنا الشيت الأخير (ش1 1) وهو عبارة عن شهادة تستقي بياناتها من الشيت الثاني (م1 1) عبر القائمة المنسدلة (سجل الطالب) وقمت بعمل زر ازرق يقوم بطباعة جميع شهادات الطلاب دفعة واحدة. المشكلة هي أن الكود الخاص بطباعة الكل يقوم بطبع جميع محتويات القائمة المنسدلة بحسب الصفوف في الشيت (م1 1) وعددها (30) وأنا عندي فقط (18) طالب فكيف أجعل الكود يتوقف عند آخر طالب في الكشف مهما كان عدد الطلاب فيه ولا يواصل الطباعة حتى النهاية لأن ذلك يترتب عليه طباعة شهادات فارغة لا تحوي بيانات. ... ارجوا مساعدتي في حل هذه المشكلة ولكم كل الود والاحترام School.xlsm

السلام عليكم ورحمة الله وبركاته أرجو التكرم بإضافة كود لطباعة جميع ما في القائمة المنسدلة ورضي الله عنكم. زر طباعة1.xlsm

أخي الكريم أشكرك جزيل الشكر لكن لم ينجح معي في ملف آخر ... و المشكلة في زر طباعة الكل هل يمكن جعل التنسيق مثل زر طباعة الصفحةالحالية؟

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

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 '====================================================== '====================================================== ' تنسيق التاريخ Private Const DtF As String = "yyyy/mm/dd" '====================================================== ' عُرض تاكست الادخال Private Const iWgt1 As Single = 240 '====================================================== Private Const Frmtop As Single = 3 Private Const Frmlft As Single = 3 Private Const iHgt As Single = 35 Private Const iTop As Single = iHgt + 2 Private Const mBox As Long = vbMsgBoxRight + vbMsgBoxRtlReading '====================================================== Private Ar() As Integer Private MyRngSeri As Range Private MyRngdate As Range Private ContRow As Long Private iRow As Long Private LastColumn As Integer Private tSr As Boolean Private MyList As String Private tAc As Boolean Private iColor1 As Variant Private iColor2 As Variant Private Sub BoxFind_Click() Dim tm As Integer Me.ListFind.Clear tm = Me.BoxFind.Tag Me.Controls("Labeldt" & tm).ForeColor = vbBlack tm = Me.BoxFind.ListIndex + 1 Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor Me.BoxFind.Tag = tm End Sub Private Sub ButtonClear_Click() kh_ClearRecord End Sub Private Sub ButtonEnd_Click() Me.ScrollBar1.Value = ContRow End Sub Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False) Dim tm As Integer '''''''''''''''''''''''''''''''' For tm = 2 To LastColumn If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then Me.Controls("Textdt" & tm) = "" End If Next End Sub Private Sub kh_AddNewRecord() Dim C As Integer '''''''''''''''''' Me.Frame1.ScrollTop = 0 kh_ClearRecord True '''''''''''''''''' Me.LabelSerial = ContRow + 1 Me.LabelSerial2 = ContRow + 1 & " - " & ContRow + 1 kh_Enabled False '''''''''''''''''' With Me.Controls("Textdt1") If .Enabled Then .SetFocus .Text = "يجب الادخال في هذه الخلية افتراضياً" .SelStart = 0 .SelLength = .TextLength Else .Text = "........" End If End With End Sub Private Sub ButtonGo_Click() With MyRngdate .Worksheet.Activate .Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select End With Unload Me End Sub Private Sub ButtonNew_Click() kh_AddNewRecord End Sub Private Sub ButtonNewCancel_Click() ScrollBar1_Change End Sub Private Sub ButtonNewSave_Click() If kh_TestBlank() Then Exit Sub Dim cRow As Long: cRow = ContRow + 1 Me.ScrollBar1.Max = cRow kh_SaveDate cRow, True Me.ScrollBar1.Value = cRow Call MsgBox(" تم حفظ السجل الجديد بنجاح ", mBox, "الحمدلله") End Sub Private Sub ButtonPrint_Click() If Me.Frame1.ScrollHeight > Me.Frame1.Height Then Print1 Else If MsgBox(" هل تريد طباعة السجل على الفورم ؟ ", vbYesNo + mBox, "طباعة على الفورم ") = vbYes Then Print2 Else Print1 End If End If End Sub Private Sub Print1() Dim ctl As Control Dim i As Integer, t As Boolean Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "B").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "C").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("B1").Resize(LastColumn, 2) .ColumnWidth = IIf(t, 28, 37) .Borders.LineStyle = 2 .WrapText = True .VerticalAlignment = xlTop End With Range("A1").ColumnWidth = IIf(t, 17, 0) If t Then AddPrintPicture Range("A1").Resize(LastColumn, 3).PrintPreview .Close False End With '------------------------ Me.Show End Sub Private Sub Print2() Print_Visible False '''''''''''''''''''''''''' If MsgBox(" هل تريد طباعة الفورم حسب هذه المعاينة ؟ ", vbYesNo + mBox, "معاينة قبل الطباعة") = vbYes Then On Error Resume Next Me.PrintForm On Error GoTo 0 End If '''''''''''''''''''''''''' Print_Visible True kh_Enabled True End Sub Private Sub Print_Visible(v As Boolean) Dim ctl As Control '''''''''''''''''''''''''' If v Then Me.BackColor = iColor1 With Me.Frame1 .BackColor = iColor2 .SpecialEffect = 3 End With Else Me.BackColor = vbWhite With Me.Frame1 .BackColor = vbWhite .SpecialEffect = 0 End With End If End Sub Private Sub ButtonSaveDate_Click() If kh_TestBlank() Then Exit Sub kh_SaveDate iRow ScrollBar1_Change Call MsgBox(" تم حفظ التغييرات بنجاح ", mBox, "الحمدلله") End Sub Private Function kh_TestBlank() As Boolean If Len(Trim(Me.Controls("Textdt1"))) = 0 Then kh_TestBlank = True Me.Controls("Textdt1").SetFocus Call MsgBox("العمود : " & Me.Controls("Labeldt1") & vbCr & vbCr & "يجب الادخال في هذه الخلية افتراضياً", mBox + vbCritical, "استخدام خاطىء") End If End Function Private Sub kh_AutoFill() Dim CelFill As Range, CFil As Range Dim R As Integer '''''''''''''''''''''''''' If tSr Then Set CelFill = Union(MyRngSeri, MyRngdate) Else Set CelFill = MyRngdate End If '''''''''''''''''''''''''' For R = 1 To CelFill.Areas.Count Set CFil = CelFill.Areas(R).Rows(ContRow + 1) With CFil .AutoFill .Resize(2), xlFillDefault End With Next Set CelFill = Nothing Set CFil = Nothing End Sub Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False) Dim MyVelue, Msg Dim C As Integer, cc As Integer '''''''''''''''''''''''''' 'On Error GoTo 1 '''''''''''''''''''''''''' Application.Calculation = xlCalculationManual '''''''''''''''''''''''''' If nR > 1 And tFil Then kh_AutoFill If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR ''''''''''''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) If Me.Controls("Textdt" & cc).Enabled = True Then With MyRngdate MyVelue = Me.Controls("Textdt" & cc).Text If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Else If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then Msg = MsgBox("الخلية في العمود : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _ & "منسقة كتاريخ والادخال الجديد رقم" & vbCr & vbCr _ & "هل تريد مسح تنسيقات الارقام السابقة ؟؟", mBox + vbYesNo, "تأكيد مسح تنسيقات التاريخ السابقة ؟؟ ") ''''''''''''''''''''''''' If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = "" End If End If .Cells(nR + 1, C).Value = MyVelue End With End If Next '''''''''''''''''''''''''' 1: Application.Calculation = xlCalculationAutomatic '''''''''''''''''''''''''' End Sub Private Sub ButtonExit_Click() Unload Me End Sub Private Sub ButtonDelete_Click() If MsgBox(" هل تريد حذف السجل رقم : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "تاكيد الحذف ") = vbNo Then Exit Sub If Me.ListFind.ListCount Then Me.ListFind.Clear MyRngdate.Rows(iRow + 1).EntireRow.Delete If Not tSr Then GoTo 1 If iRow = ContRow Then GoTo 1 With MyRngSeri .Cells(iRow + 1, 1).Value = iRow Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries End With 1: Me.ScrollBar1.Max = ContRow - 1 ScrollBar1_Change Call MsgBox(" تم حذف السجل بنجاح ", mBox, "الحمدلله") End Sub Private Sub ButtonTop_Click() If ContRow Then Me.ScrollBar1.Value = 1 End Sub Private Sub CheckFind_Click() Me.ListFind.Clear Me.LblFindCount = 0 End Sub Private Sub CheckFindDate_Click() If Me.CheckFindDate.Value = True Then kh_SetDate Me.TextFind '''''''''''''''''''''''''''' End If End Sub Private Sub CommandButton1_Click() ActiveWorkbook.save Call MsgBox(" تم حفظ الكل بنجاح ", mBox, "الحمدلله") End Sub Private Sub CommandButton2_Click() ChaingeLanguage "Arabic" TextFind.SetFocus End Sub Private Sub CommandButton3_Click() ChaingeLanguage "English" TextFind.SetFocus End Sub Private Sub CommandButton4_Click() Me.TextFind.Value = "" End Sub Private Sub CommandButton6_Click() a = Application.Height - 10: b = Application.Width With Me .Width = .Width * 1.1 .Height = .Height * 1.1 .zoom = .zoom * 1.1 .Top = (a - .Height) / 2 .Left = (b - .Width) / 2 End With End Sub Private Sub CommandButton7_Click() a = Application.Height - 10: b = Application.Width With Me .Width = .Width / 1.1 .Height = .Height / 1.1 .zoom = .zoom / 1.1 .Top = (a - .Height) / 2 .Left = (b - .Width) / 2 End With End Sub Private Sub LabelH2_Click() Call MsgBox(" سيتم تحويل اي قيمة تضعها في مربع النص للبحث " _ & vbCr & vbCr & "الى تاريخ بالتنسيق الافتراضي للفورم ,,,,,,," _ & vbCr & String$(40, "=") _ & vbCr & vbCr & "مع امكانية ادخال رقم صحيح بين 1 الى 31 ليفهم على انه " _ & vbCr & vbCr & "تاريخ اليوم للشهر الحالي والسنة الحالية " _ , mBox + vbQuestion + vbApplicationModal, "تعليمات") ''''''''''''''''''''''''''' End Sub Private Sub ListFind_Click() Dim RR As Long RR = Me.ListFind.Column(1) Me.ScrollBar1.Value = RR End Sub Private Sub ScrollBar1_Change() Dim MyVelue Dim C As Integer, cc As Integer Me.Frame1.ScrollTop = 0 With Me.ScrollBar1 If ContRow = 0 Then .Min = 1 iRow = .Value: ContRow = .Max End With ''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) With MyRngdate If IsDate(.Cells(iRow + 1, C)) Then MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF) Else: MyVelue = .Cells(iRow + 1, C).Value2 End If End With On Error Resume Next Me.Controls("Textdt" & cc).Text = "" Me.Controls("Textdt" & cc).Text = MyVelue On Error GoTo 0 Next '------------------------------ Me.LabelSerial.Caption = iRow Me.LabelSerial2.Caption = iRow & " - " & ContRow kh_Enabled True End Sub Private Sub TextBox1_Change() End Sub Private Sub TextFind_Change() With Me.ListFind If .ListCount Then .Clear End With Me.LblFindCount = 0 Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False) End Sub Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) If Me.CheckFindDate.Value = False Then Exit Sub kh_SetDate Me.TextFind End Sub ' هذا الكود يرغمك بادخال تاريخ Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control) Dim dtest, dt dtest = dCntrl If Not IsDate(dtest) Then If IsNumeric(dtest) Then On Error Resume Next dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF) If Err Then dt = Format(Date, DtF) On Error GoTo 0 Else dt = Format(Date, DtF) End If Else: dt = Format(CDate(dtest), DtF) End If dCntrl = dt End Sub Private Sub TextSerial_Change() Dim v v = Me.TextSerial.Text If Len(v) = 0 Then Exit Sub If Not IsNumeric(v) Then GoTo 1 If v = 0 Or v > ContRow Then GoTo 1 Exit Sub '======================= 1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1) End Sub Private Sub TextSerial_AfterUpdate() If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = "" End Sub Private Sub kh_Enabled(ByVal Ebl As Boolean) Me.ButtonNewSave.Visible = Not Ebl Me.ButtonNewCancel.Visible = Not Ebl Me.ButtonNew.Visible = Ebl Me.ButtonSaveDate.Visible = Ebl '''''''''''''''''''''''''''''''''''''''''''' Me.ButtonPrint.Enabled = Ebl Me.ButtonSaveDate.Enabled = Ebl Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False) '''''''''''''''''''''''''''''''' Me.ButtonEnd.Enabled = CBool(iRow <> ContRow) Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1) Me.ButtonNewCancel.Enabled = IIf(iRow, True, False) Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl) End Sub Private Sub ButtonSerach_Click() Dim tb1 As Boolean, ib As Boolean Dim R As Long, RR As Long Dim C As Integer Dim MyFind, MySrch, MyVelue '''''''''''''''''''''' Me.ListFind.Clear If Len(Trim(Me.TextFind)) = 0 Then Exit Sub ''''''''''''''''''''' C = Me.BoxFind.ListIndex + 1 tb1 = CBool(Me.CheckFindDate.Value = True) If tb1 Then If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind MyFind = CDbl(CDate(Me.TextFind)) Else MyFind = Me.TextFind.Value End If ''''''''''''''''''''''' With MyRngdate.Cells(2, Ar(C)) For R = 1 To ContRow If Len(Trim(.Cells(R, 1))) Then If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare)) If ib Then MyVelue = .Cells(R, 1).Value If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Me.ListFind.AddItem MyVelue Me.ListFind.List(RR, 1) = R RR = RR + 1 End If End If Next End With Me.LblFindCount = Me.ListFind.ListCount If RR = 0 Then MsgBox " لا توجد نتائج لبحثك هذا ", mBox, "تنبيه" ''''''''''''''''''''''''' End Sub Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "") tSr = TypeName(Evaluate(aSr)) = "Range" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With ThisWorkbook If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr) Set MyRngdate = .Worksheets(MySht).Range(MyAddrs) End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With MyRngdate ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row LastColumn = .Cells.Count End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Col As Range Dim ii As Integer ReDim Ar(1 To LastColumn) For Each Col In MyRngdate.Cells ii = ii + 1 Ar(ii) = Col.Column - MyRngdate.Column + 1 Next ''''''''''''''''''''''''''' End Sub Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean If Not Rng.Comment Is Nothing Then MyList = Trim(Replace(Rng.Comment.Text, Chr(10), "")) MyList = Replace(MyList, " ", "") If TypeName(Evaluate(MyList)) = "Range" Then kh_TestType = True End If End If End Function Private Sub UserForm_Activate() Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double Dim MyBox As Control, MyLabl As Control Dim t As Integer Dim tTp As Boolean Dim MyType As String ''''''''''''''''''''' If tAc Then Exit Sub ''''''''''''''''''''' Me.Caption = MyRngdate.Worksheet.Name MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2) With Frame1 If MyScrollHeight > .Height Then .ScrollBars = 2 .ScrollHeight = MyScrollHeight End If End With MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2)) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' For t = 1 To LastColumn tTp = kh_TestType(MyRngdate.Cells(1, Ar(t))) MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1") Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True) With MyBox .Move Frmlft, MyTop, iWgt1, iHgt .TextAlign = 3 If tTp Then .BackColor = 16763955 .ControlTipText = "إختر من القائمة..تحياتى عبدالبارى البنا" On Error Resume Next .List = Range(MyList).Value If Err Then .AddItem Range(MyList).Cells(1, 1).Value On Error GoTo 0 End If If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then .BackStyle = 0 .TextAlign = 2 .SpecialEffect = 3 .Enabled = False End If End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True) With MyLabl .Move iWgt1 + Frmlft, MyTop, MyWith, iHgt .SpecialEffect = 3 .TextAlign = 2 .Caption = MyRngdate.Cells(1, Ar(t)) End With ''''''''''''''''''''''''''''''''''' Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2 MyTop = MyTop + iTop Next ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.BoxFind .Style = 2 .Tag = 1 .ListIndex = 0 End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.ScrollBar1 .Max = ContRow If ContRow Then .Min = 1 '.Value = ContRow Else kh_AddNewRecord End If End With tAc = True ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Me.TextBox1.Value = ورقة13.Range("f18").Value CheckFind.Value = True End Sub Private Sub UserForm_Initialize() Dim LaCouleur As String Dim Te LaCouleur = xlThemeColorLight1 Te = ("&&..الله اكبر..&& اهلا بكم فى برنامج شئون العاملين بالتربية والتعليم ........................إعداد وتصميم .. عبدالبارى البنا &&..ولله الحمد..&&") Me.WebBrowser1.Navigate _ "about:<html><body scroll='no'><font color= " & LaCouleur & " size='4' face='NEW'>" & _ "<marquee direction=right>" & Te & "</marquee></font></body></html>" 'Dim Zo% 'Dim ZH#, ZW#, AL#, AT#, AH#, AW# 'Dim FH!, FW! ''''''''''''''''''''''' 'AH = Application.Height: AW = Application.Width 'AL = Application.Left: AT = Application.Top 'FH = Height: FW = Width 'ZH = AH - FH: ZW = AW - FW: Zo = zoom 'If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW) ''''''''''''''''''''''' 'Move AL, AT, AW, AH 'If Zo <> 100 Then zoom = Zo '=========================================== iColor1 = Me.BackColor iColor2 = Me.Frame1.BackColor End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ' Me.TextBox1.Value = ورقة13.Range("f18").Value End Sub Private Sub UserForm_Terminate() Set MyRngdate = Nothing Erase Ar End Sub Private Sub WebBrowser1_StatusTextChange(ByVal Text As String) End Sub كود اخر ولا في الاحلام

لو بحثت لوجدت الكثير ربما يفيك هذا الرابط Searched for 'طباعة الكل pdf' in موضوعات (officena.net) بالتوفيق

مرحبا بك في أي وقت الاكواد كما يلي طباعة الصفحة الحالية ( صفحة واحدة ) Sub print_1() ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub طباعة كل الموظفين ( ولعمل ذلك تم عمل عمود مساعد لوضع رقم مسلسل للموظفين ) Sub print_1() ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub Sub print_all() ' الاعلان عن متغير من النوع الرقمي الصحيح Dim x As Integer 'عمل حلقة تكرارية بديتها القيمة الموجودفي في الخلية ام 3 وتنتهي في الخلية ام 4 For x = [m3] To [m4] 'أمر الطباعة ActiveWindow.SelectedSheets.PrintOut From:=1, to:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False ' زيادة القيمة في الخلية بمقدار 1 للانتقال للشخص التالي [m3] = [m3] + 1 ' تكرار التنفيذ Next [m3] = 1 End Sub إذا كنت لا ترغب في العمود المساعد يمكنك عمل الرقم الوظيفي قائمة منسدلة ويمكنك الاطلاع على الرابط التالي الكود في الأساس للاستاذ بن عليه حاجي على ما أتذكر ( فقط تم توظيفه ليناسب طلب السائل ) الاداة التي تنقل بين أرقام الموظفين ( أداة تحكم ) لا يوجد بها كود فقط يمكن ضبطها من خلال خصائصها طباعة الكل ومفرد.xlsm

الأخوة الأفاضل .......... السلام عليكم ورحمة الله وبركاته........... أريد عمل زر لطباعة كل القوائم دفعة واحدة .............. شكراً لكم قوائم 2018.rar

فضلا جرب المرفق طباعة الكل ومفرد.xlsm

- عمل كود ( طباعة الكل ) لـ شهادات ترم أول + شهادات أخر العام - عمل كود ( طباعة محددة من .... إلى ) لـ شهادات ترم أول + شهادات أخر العام ولكم جزيل الشكر الصف الأول الإبتدائي.rar

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

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

الكود طباعة الكل يعود إلى الصفحة 1 بعد أن يكمل عملية الطباعة... وبالنسبة للعدد الذي يصل إلى الآخر فهذا لا أستطيع أن أعرفه لأن البيانات Source غير موجودة في الملف.. الكارتة1.xlsm

السلام عليكم الكود السابق تركته للصفحات الحالية (صفحة واحدة)، أما كود طباعة الكل فقد تم إنشاؤه من الكود السابق ثم التعديل عليه لطباعة جميع البطاقات مع إخفاء الصفوف الصفرية في كل بطاقة... أرجو أن يفي الغرض المطلوب. ملاحظة : تم إضافة معادلة في الخلية A2 لتحديد العدد الإجمالي للبطاقات. لم يتم تجربة الكود لأن الملف مرتبط ببيانات غير موجودة فيه. الكارتة.xlsm

السلام عليكم ورحمة الله وبركاته .. اولا اشكركم على هذا المنتدى الاكثر من رائع والاستفادة منه ممتاوة جدا ثانيا :- انا موظف تم تعييني لادارة التنسيق والمتابعة لمكتب المدير العام في الشؤون المالية في وزارة معينة فبيكون معنا دوائر واقسام نوجه لهم خطابات من مكتب المدير العام - فهل يوجد برنامج اكسيل يعمل على تنظيم نظام المراسلات مثلا يشمل رقم المراسلة وتاريخها وعنوانها والجهة المرسل لها وهل تم تحويلها يعني متابعة الرسالة وين مكان وجودها وهل تم الانتهاء منها والملاحظات عليها وبرنامج طباعة هذه البيانات مثل طباعة الرسائل الموجهة لدائرة معينة او طباعة الكل او طباعة قسم معين . خالص شكري وتقديري لكم (

شكرا جزيلا بس فيه ملحوظ عند طباعة الكل يطبع الصفحة الأولي فارغة . لماذا ؟

غير واضح مقصدك انت تحدد الكل لكي تطبع الكل / لكن في نفس الوقت لا تريد طباعة الكل

السلام عليكم لدي ملف ياخد بياناته من شيت داتا وشيت الداتا به بيانات اكتر من 500 اسم اريد طباعة الكل او من من رقم الى رقم ... ارجو المساعدة انتبه من فضلك , فطالما ان طلبك لم يتم حله الا بالأكواد .. فكان لزاما عليك رفع الملف بإمتداد Xlsm وذلك تجنباً لإهدار وقت الأساتذة ..تـــم اعادة رفع الملف Ek_4.xlsm

السلام عليكم اخي اليك البرنامج قد وقع خطاء في تحميله اليك البرنامج الذي اريد العمل به واريد عند الاختيار من مربع تحرير وسرد و زر الحاق المحدد و زر الحاق الكل اخي و زر طباعة القائمة عند الاختيار من مربع تحرير وسرد اخي بارك الله فيك وشكر جزيلا الوسائل المكتبية.rar

وبعد ذلك هل تقصد طباعة الكل بطريقة آلية؟؟؟ إذا كان هذا هو المطلوب الثاني فهذه بعض نتائج البحث في منتدانا الرائع Showing results for 'طباعة الكل'. - أوفيسنا (officena.net) بالتوفيق

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

أخي @محمد يوسف ابو يوسف واضح أنني لم استطع شرح ما اريد بشكل جيد أخي الفاضل كود الطباعة الموجود في الزر الاساسي والمسمى طباعة الكل يقوم بتغيير محتويات الشهادة ويرسلها الى البرنتر لطباعتها والذي اريده هو تعديل هذا الكود فقط لحفظ الصفحة بي دي اف بدلا من طباعتها وقد توصلت الى الكود لكن يطلب مني تسمية الملف في كل ورقة يحفظها وانا لا اريد ذلك أريده أن يطع كل الاوراق في ملف واحد فقط ( المطلوب ان يحتوي هذا الملف على الشهادات فقط ولا اريد شيئا اخر )

هل هذا ماتقصد...اضغط زر طباعة الكل ..ثم اذهب الي برتيشن d تجد الملف محفوظ بتاريخ اليوم الملفطباعة الشهادات.xlsm