طارق_نادر

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

كل الشكر والتقدير ارفع لك القبعة احتراما لخبرتك الكبيرة تم المطلوب بكل حرفية اخي الفاضل والعلامة بن علية

هذه الداله اخي الكريم =ArbNum2Text(G6) & " فقط "

للرفع

لدي كود تفقيط حصلت عليه من المنتدى الكريم ولكن اريد التعديل عليه في جزئية بسيطة وهي رقم (200) اريد ان يكتبها الكود مائتان ولكن الكود يكتبها مائتا اظن السبب ان هناك كلمة تليها وهي درجة ولكني حذفتها لاسباب خاصة بمشروعي ارجو المساعدة رجاء '-- Abo Hadi, 28/07/2003 --' '-- Last update on 28/07/2006 ' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت 'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب ' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط 'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح Option Explicit Public Const vArabic As Byte = 1 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null) myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue) End Function Private Function Delete(S As String, Index As Integer, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Private Function Insert(Source, S As String, Index As Integer) As String Dim LPart As String Dim RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Private Function AddAnd(S1 As String, S2 As String, S3 As String, _ And_ As String, Lang As Byte) As String Dim InAnd_ As String Dim CollectS As String If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " " If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = "" CollectS = S1 + And_ + S2 If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = "" AddAnd = CollectS + And_ + S3 End Function Private Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1 As String Dim Sngl_2 As String K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تانِ" Else Sngl_2 = Sngl_2 & "انِ" End If End If If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1)) Select Case LLeter Case 201 ' "ة" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تانِِ" Case 236 ' "ى" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يانِ" Case 199 ' "ا" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Case 193 ' "ء" If Right(Sngl_1, 2) = "اء" Then If Sex = 1 Then Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Else Sngl_1 = Sngl_1 & "انِ" End If End If Case Else If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "انِ" End Select If Sngl_2 <> "" Then S2Double = Sngl_1 & " " & Sngl_2 Else S2Double = Sngl_1 End If End Function Private Function Fmale(num As Byte, Sex As Byte, Female()) As String Dim Two(1 To 4) As String Dim InSex As Byte Two(1) = "أحدَ" Two(2) = "اثنانِ" Two(3) = "إحدَى" Two(4) = "ة" Select Case Sex Case vMale: Select Case num Case 1: Fmale = Mid(Female(1), 1, 4) Case 2: Fmale = Two(2) Case 8: Fmale = Female(num) + "ي" + Two(4) Case 3 To 7, 9, 10: Fmale = Female(num) + Two(4) Case 11: Fmale = Two(1) + " " + Female(10) Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10) Case 13 To 19: Fmale = Female(num - 10) + Two(4) + " " + Female(10) End Select Case vFemale: Select Case num Case 1 To 10: Fmale = Female(num) Case 11: Fmale = Two(3) + " " + Female(10) + Two(4) Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4) Case 13 To 19: Fmale = Female(num - 10) + " " + Female(10) + Two(4) End Select End Select End Function Private Function Tens(num As Byte, Female()) As String Const Noon = "ونَ" Select Case num Case 2: Tens = Female(10) + Noon Case 3 To 9: Tens = Female(num) + Noon End Select End Function Private Function Hunds(num As Byte, Female()) As String Const Hund = "مائة" Select Case num Case 1: Hunds = Hund Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3) Case 3 To 9: Hunds = Female(num) + Hund End Select End Function Private Function Tenteen(num As Byte, ETens()) As String Const een = "een" num = num Mod 10 Select Case num Case 3 To 9: Tenteen = Mid(ETens(num), 1, Len(ETens(num)) - 1) + een End Select End Function Private Function EHunds(num As Byte, ESingle()) As String EHunds = ESingle(num) + " hundred" End Function Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String Const And_ As String * 1 = "و" Const Lang = vArabic Dim PartNum(0 To 7) As Long Dim Result1(0 To 8) As String Dim Parts_(0 To 13) As String Dim Female(1 To 10) As Variant Dim TempI As Byte Dim Sex2 As Byte Dim K As Byte Dim Only_ As String Dim OnlyPart As String Dim Part_ As String Dim TempS As String Dim Sngl_1 As String Dim Sngl_2 As String Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then AOnly = RTrim("لا شيءَ " & Single_) ' تم تغيير صفر إلى لا شيء Else AOnly = FracS & " " & Single_ End If Exit Function End If Female(1) = "واحدة" Female(2) = "اثنتانِ" Female(3) = "ثلاث" Female(4) = "أربع" Female(5) = "خمس" Female(6) = "ست" Female(7) = "سبع" Female(8) = "ثمان" Female(9) = "تسع" Female(10) = "عشر" Parts_(0) = "" Parts_(1) = "ألف" Parts_(2) = "مليونَ" Parts_(3) = "مليار" Parts_(4) = "ترليونَ" Parts_(5) = "كدرليونَ" Parts_(6) = "كوينتليونَ" Parts_(7) = "" Parts_(8) = "آلافٍ" Parts_(9) = "ملايينَ" Parts_(10) = "ملياراتٍ" Parts_(11) = "ترليوناتٍ" Parts_(12) = "كدرليوناتٍ" Parts_(13) = "كوينتليوناتٍ" K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" And InStr(2, Plural, Sngl_2) > 0 Then Sngl_2 = "" End If For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K Sex2 = Sex For K = 0 To (Parts - 1) If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = Hunds(CByte(N1), Female()) If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1) Select Case TempI Case 1 To 2: If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex Case 3 To 19: N3_ = Fmale(TempI, CByte(Sex), Female()) Case 20 To 99: N2_ = Tens(CByte(N2), Female()) If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female()) If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدَى" End Select OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang) '{------------------------------------------} If PartNum(K) > 100 Then Select Case TempI Case 1, 2: OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang) End Select End If '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = Parts_(Parts - K - 1) If Part_ <> "" Then Select Case TempI Case 2: Part_ = Part_ + "انِ" Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 7) Case 11 To 99: Part_ = Part_ + "اً" End Select End If End If '{------------------------------------------} If Part_ <> "" Then If TempI >= 1 And TempI <= 2 Then OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang) Else OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang) End If End If Result1(K) = OnlyPart Next K '{------------------------------------------} For K = 0 To Parts - 1 Only_ = AddAnd(Only_, Result1(K), "", And_, Lang) Next K If FracS <> "" Then If Only_ <> "" Then FracS = " " + FracS Only_ = AddAnd(Only_, FracS, "", And_, Lang) End If If Only_ <> "" Then If Mid(Only_, Len(Only_), 1) = "ا" Then If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If If TempS = "000" Then If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If End If '{------------------------------------------} If FracS = "" Then Select Case TempI Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang) End If Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If Case 11 To 99: If Sngl_1 <> "" Then Only_ = AddAnd(Only_, Sngl_1, "", "", Lang) N1_ = Mid(Only_, Len(Only_), 1) Select Case N1_ Case "ة", "ى", "أ", "ء", "اء" Case Else Only_ = Only_ + "اً" End Select N1_ = Mid(Only_, Len(Only_) - 2, 3) 'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24 If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then Only_ = Left(Only_, Len(Only_) - 1) End If If Sngl_2 <> "" Then If Right(Only_, 1) = "ا" Then Only_ = AddAnd(Only_, Sngl_2 & "اً", "", "", Lang) Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If End If End Select Else Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang) End If AOnly = (Only_) End Function Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant Dim Num_ As String Dim K As Byte Dim Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = CStr(InNum) K = InStr(1, Num_, ".", 1) If K > 0 Then Dec = Len(Num_) - K 'If Dec < 2 Then Dec = 2 Else Dec = 0 End If FType = FracType If FType <> 2 Then FType = 1 S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType) End Function Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _ Single_ As String, Plural As String, _ FSex As Byte, SFrac As String, PFrac As String, _ FracType As Byte) As Variant Dim Leng As Byte Dim Parts As Byte Dim K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String Dim And_ As String If IsNull(InNum) Then B_Only = Null Exit Function End If If Dec > 6 Then Dec = 6 Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0")) If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = "" If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1) FracVal = Val(FracS) Do While Len(FracS) < Dec + 2 FracS = Insert(FracS, "0", 1) Loop DoProcess: If FracVal = 0 Then FracS = "" FracNum = Trim(Mid(FracS, 3, Len(FracS))) If FracS <> "" Then Select Case FracType Case 2 Select Case Lang Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0"))) End Select Case 3 Select Case Lang Case vArabic: FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac) End Select Case 4 Leng = Len(FracNum) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng FracNum = Insert("0", FracNum, 1) Next K Select Case Lang Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType) End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) If Parts > 7 Then B_Only = InNum Exit Function End If For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracType = 3 Then And_ = "و " Else And_ = "و" If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang)) End Select End Select If Only <> "" Then Select Case Lang Case vArabic: B_Only = Only End Select End If End Function 'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث ' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات Function ArbNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = 2, _ Optional ByVal FractionType = 4, _ Optional ByVal CurrencySingle = "جنيه", _ Optional ByVal CurrencyPlural = "جنيهات", _ Optional ByVal CurrencySex = 0, _ Optional ByVal FractionSingle = "قرش", _ Optional ByVal FractionPlural = "قروش", _ Optional ByVal FractionSex = 0) As Variant Dim Negative As String If IsNull(InNum) Then ArbNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "سالبُ " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) End If ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 2 InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) 'If InNum <> Fix(InNum) Then If Val(Right(InNum, DecimalPlaces)) > 0 Then If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح Dim m m = " فقطُ لا غيرَ" ArbNum2Text = Negative & _ B_Only(CDec(myNz(InNum, 0)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) & m End Function

احفظ الملفات الورد على شكل ويب ثم افتح ملف اكسل جديد ثم افتح ملف الويب عن طريق الاكسل واحفظه وهكذا...............

حاولت حسب خبرتي البسيطة ولكن ان اشاء الكريم سيكون مشاركاتي افضل بفضل جهودكم معنا

عمل جميل جدا يامعلمي الفاضل ولكن اريد ان اشارك بحل اخر لايرتقي لمستوى عملك اذا تكرمت علي والفضل يرجع لك وللاعضاء الكرام اجتهتد ولعله يستفيد منه صاحب الطلب http://www.gulfup.com/?EA5bZK

حسنا انظر المرفق واخبرني انا بأنتظارك لألبي طلبك خطوة خطوة ستجد في العمود أ الاسماء تنتقل بشكل مباشر الى عامود ب واذا اردت المزيد من التعديل فأخبرني http://www.gulfup.com/?Z3ea1v

ارجو اخي الكريم التوضيح اكثر كوضوح الشمس

اريد ان اشارك بهذا المشروع الجميل والمفيد جدا بكود اهداني اياه اخ فاضل في هذا المنتدى مشكورا ارجو ان يستفيد به غيري وهو عبارة كود طباعة مرن ورائع Sub PrintSelectedSheets() ' Display "Printer Setup" dialog box Application.Dialogs(xlDialogPrinterSetup).Show ' Option Explicit ' Sub SelectSheets() Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim cb As CheckBox Dim Numcop As Long Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet X = CurrentSheet.Name Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets and hidden sheets If Application.CountA(CurrentSheet.Cells) <> 0 And _ CurrentSheet.Visible Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).Text = _ CurrentSheet.Name TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to print" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Get the number of print copies for each report Numcop = Application.InputBox("Enter number of copies to print:", _ "How Many Copies?", 1, Type:=1) If Numcop = 0 Then ElseIf Len(Numcop) > 0 Then End If ' Display the dialog box CurrentSheet.Activate Dim cnt As Integer Application.ScreenUpdating = True If SheetCount <> 0 Then If PrintDlg.Show Then For Each cb In PrintDlg.CheckBoxes If cb.Value = xlOn Then If cnt = 0 Then Worksheets(cb.Caption).Select ' Replace:=False 'Activate Else Worksheets(cb.Caption).Select Replace:=False 'Activate End If cnt = cnt + 1 End If Next cb ActiveWindow.SelectedSheets.PrintOut copies:=Numcop 'ActiveSheet.PrintPreview 'for debugging End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Sheets(X).Select End Sub

هذا هو الكود اهداني اياه احد الاخوان الافاضل في المنتدى من مكتبته الخاصة كل الشكر لهو ولك اخي الفاضل Private Sub CmdPrint_Click() ' Display "Printer Setup" dialog box Application.Dialogs(xlDialogPrinterSetup).Show ' Option Explicit ' Sub SelectSheets() Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim cb As CheckBox Dim Numcop As Long Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet X = CurrentSheet.Name Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets and hidden sheets If Application.CountA(CurrentSheet.Cells) <> 0 And _ CurrentSheet.Visible Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).Text = _ CurrentSheet.Name TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to print" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Get the number of print copies for each report Numcop = Application.InputBox("Enter number of copies to print:", _ "How Many Copies?", 1, Type:=1) If Numcop = 0 Then ElseIf Len(Numcop) > 0 Then End If ' Display the dialog box CurrentSheet.Activate Dim cnt As Integer Application.ScreenUpdating = True If SheetCount <> 0 Then If PrintDlg.Show Then For Each cb In PrintDlg.CheckBoxes If cb.Value = xlOn Then If cnt = 0 Then Worksheets(cb.Caption).Select ' Replace:=False 'Activate Else Worksheets(cb.Caption).Select Replace:=False 'Activate End If cnt = cnt + 1 End If Next cb ActiveWindow.SelectedSheets.PrintOut copies:=Numcop 'ActiveSheet.PrintPreview 'for debugging End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Sheets(X).Select End Sub

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

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

الف مبروك وادعوا لك بمزيد من العطاء

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

مجهود رائع وطريقة شرح جميلة جزاء الله عنا كل خير

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

كل الشكر والتقدير معلمي الفاضل وجاري على تحليل الكود وايجاد الخطأ السابق

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

CLASS MODULES ماوظيفتها مع مثال رجاءا وماالفر بينها وبين وظيفة MODULES ولماذا استعمالاتها قليلة في اغلب المشاريع المطروحة وشكرا لسعة صدركم

"اذا كان عندك مديول أو كود وعايز تربطه بزر اعمل رايت كيك على الزر واختار assign macro ,اختر اسم المديول ثم اوكي" اشكرك جزيل الشكر ع هذه المعلومة القيمة هكذا سببدأ التقدم بارك الله فيك

اشكر توضحيك فهمت المقصود

نعم صدقت اخي الفاضل

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