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

هناك مسافة زائدة في اسم الصفحة "يناير "يجب ازالتها قم باضافة شيت تحت اي اسم مثلاً "Summation" بدون كود هذه المعادلة =SUM('يناير:مارس'!D4) أو هذا الكود Option Explicit Sub test() Dim First As Worksheet Dim Last As Worksheet Set First = Sheets("يناير") Set Last = Sheets("مارس") With Sheets("Summation").Range("D4") .Formula = "=SUM('" & First.Name & ":" & Last.Name & "'!D4)" .Value = .Value End With End Sub النلف مرفق Hissam.xlsm

قم بتسمية الشيت الاول باسم Salim ثم نفذ هذا الماكرو Option Explicit '+++++++++++++++++++++++++++++++++++++++++ Sub ADD_SH_with_HyperLink() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 1/10/2020 Dim Rg As Range Dim sh As Worksheet Dim LB%, i%, x%, t% Dim ws As Worksheet Set sh = Sheets("Salim") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> "Salim" Then ws.Delete End If Next Application.DisplayAlerts = True LB = sh.Cells(Rows.Count, 2).End(3).Row For x = 2 To LB If sh.Range("b" & x) <> "" Then t = sh.Range("b" & x).MergeArea.Rows.Count If Not Application.Evaluate("ISREF('" & sh.Range("b" & x) & "'!A1)") Then Sheets.Add after:=Sheets(Sheets.Count) With ActiveSheet .Name = sh.Range("b" & x) sh.Range("a1:d1").Copy .Range("A1").PasteSpecial (xlPasteAll) .Range("C:C").Delete .Range("A2") = sh.Range("A" & x) .Range("B2") = sh.Range("B" & x) .Range("C2") = sh.Range("D" & x) .Hyperlinks.Add Anchor:=.Range("F1"), _ Address:="", SubAddress:= _ "Salim!A1", TextToDisplay:="Goto SALIM" With .Range("a1").CurrentRegion .ColumnWidth = 19 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .Rows(2).InsertIndent 1 .Cells(2, 1).Select End With With .Range("F1") With .Font .Bold = True: .Size = 20 .ColorIndex = vbBlack .Italic = True End With .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns.AutoFit End With End With End If 'sh,exist End If '.value<>"" x = x + t - 1 Next x sh.Select Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++ الملف مرفق ABd_Naser_Sheet.xlsm

تفضل يمكنك استخدام هذه المعادلة =SUMPRODUCT(SUMIF(INDIRECT("'"&sheets&"'!"&"b2:b100"),A2,INDIRECT("'"&sheets&"'!"&"d2:d100"))) تجريبى1.xlsx

السلام عليكم تم عمل ترقية جديدة للمنتدى الان اذا واجهتك مشاكل بعد التحديث يرحى افراغ الكاش من المتصفح مثلا فى جوجل كروم او ختصارا CTR+Shift+DEL

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

اذا كان هذا المطلوب اضغط على افضل اجابة لاغلاق الموضوع

تم مغالجة الأمر و زيادة حبتين بجيث يمكنك الاتنقال الى اي شيت من خلال الضغط عل اسمها من الخلايا الصفراء صغحة (Salim) والعودة من اي شيت الى الرئيسية من حلال الضغط على الخلية Go to Salim ( لكن في المرة القادمة عليك بتوضيح كل شيء لعدم اهدار الوقت) Option Explicit '+++++++++++++++++++++++++++++++++++++++++ Sub ADD_SH_with_HyperLink() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 1/10/2020 ' Dim Rg As Range Dim sh As Worksheet Dim LB%, i%, x%, t% Dim Ws As Worksheet Set sh = Sheets("Salim") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Ws In Sheets If Ws.Name <> "Salim" Then Ws.Delete End If Next Application.DisplayAlerts = True LB = sh.Cells(Rows.Count, 2).End(3).Row For x = 2 To LB If sh.Range("b" & x) <> "" Then t = sh.Range("b" & x).MergeArea.Rows.Count If Not Application.Evaluate("ISREF('" & sh.Range("b" & x) & "'!A1)") Then Sheets.Add after:=Sheets(Sheets.Count) With ActiveSheet .Name = sh.Range("B" & x) sh.Range("A1:D1").Copy .Range("A1").PasteSpecial (11) .Range("A1").PasteSpecial (8) .Hyperlinks.Add Anchor:=.Range("F1"), _ Address:="", SubAddress:= _ "Salim!A1", TextToDisplay:="Goto SALIM" With .Range("A1").CurrentRegion .ColumnWidth = 19 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .Rows(2).InsertIndent 1 .Cells(2, 1).Select End With With .Range("F1") With .Font .Bold = True: .Size = 20 .ColorIndex = vbBlack .Italic = True End With .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns.AutoFit End With End With End If 'sh,exist End If '.value<>"" x = x + t - 1 Next x sh.Select add_data add_Hyper Application.CutCopyMode = False Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++++++ Sub add_data() Dim sh As Worksheet Dim LB%, i%, x%, t% Dim Ws As Worksheet Dim spec_sh As Worksheet Dim LS%, Ro% Set sh = Sheets("Salim") LS = sh.Cells(Rows.Count, 1).End(3).Row For i = 2 To LS t = sh.Cells(i, 2).MergeArea.Rows.Count Set spec_sh = Sheets(sh.Cells(i, 2) & "") Ro = spec_sh.Cells(Rows.Count, 1).End(3).Row + 1 sh.Cells(i, 1).Resize(t, 4).Copy _ spec_sh.Range("A" & Ro) i = i + t - 1 Next i End Sub '+++++++++++++++++++++++ Sub add_Hyper() Dim Ws As Worksheet Dim K% Set Ws = Sheets("Salim") Ws.Range("F2:F" & Sheets.Count).Clear For K = 2 To Sheets.Count Ws.Range("F" & K) = Sheets(K).Name Ws.Range("F" & K).Hyperlinks.Add _ Anchor:=Ws.Range("F" & K), _ Address:="", _ SubAddress:="'" & Sheets(K).Name & "'!A1", _ TextToDisplay:="Go TO " & Sheets(K).Name Next With Ws.Range("F2").Resize(K - 2) .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14: .Font.Bold = True End With End Sub الملف مرفق Adb_Explicit.xlsm

بصراحة ليس لدي خبرة في مجال ايميلات الاوتولوك ولكن جربي هذا الكود واعلميني بما يحدث معك ليس لدي ايميل مربوط بالوتولوك حتى اجربه sub sendemail If MsgBox("Are you sure you would like to send this data?", vbYesNo) = vbNo Then Exit Sub Dim outlook As Object Dim newEmail As Object Dim xInspect As Object Dim pageEditor As Object Dim rng As Range Application.ScreenUpdating = False Set rng = Range("E2:E100") ActiveSheet.Sort.SortFields.Clear rng.Sort Key1:=rng.Cells(1), Order1:=xlAscending, Header:=xlNo Set outlook = CreateObject("Outlook.Application") Set newEmail = outlook.CreateItem(0) With newEmail .To = "Myemail.com" .CC = "" .BCC = "" .Subject = "" .Body = "Please see the report . Thanks" .Display Set xInspect = newEmail.GetInspector Set pageEditor = xInspect.WordEditor Sheet1.Range("a2:d100").Copy pageEditor.Application.Selection.Start = Len(.Body) pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText) .Display .Send Set pageEditor = Nothing Set xInspect = Nothing MsgBox "Your Orders Have Been Sent" End With End Sub

جرب المرفق من مشاركة سابقة لاستاذنا الفاضل @jjafferr 0.accdb

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

تم معالجة الامر بطريقة اخرى (عدم كتابة الترقيم في العامود الأول لانه يدرج تلقائياً) القائمة المنسدلة مطاطة (تستيجيب لاي تعدبل أو زيادة في البيانات) Psycho.xlsx

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

تم التعديل Option Explicit Sub GetMe_All() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim LR1 As Single, LR2 As Single Dim m As Single, t As Single, x As Single Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") LR1 = sh1.Cells(Rows.Count, 2).End(3).Row LR2 = sh2.Cells(Rows.Count, 1).End(3).Row m = 2 If LR1 > 1 Then Union(sh1.Range("A2:A" & LR1), sh1.Range("B2:B" & LR1), _ sh1.Range("D2:D" & LR1)).ClearContents End If For x = 2 To LR2 t = sh2.Cells(x, 2).MergeArea.Rows.Count With sh1.Cells(m, 2) .Offset(, -1) = "From " & x - 1 & " To " & t + x - 2 .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With x = x + t - 1 m = m + 1 Next End Sub الملف من جديد Naser_1.xlsm

Required code Option Explicit Sub Get_All() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim LR1 As Single, LR2 As Single Dim m As Single, t As Single, x As Single Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") LR1 = sh1.Cells(Rows.Count, 2).End(3).Row LR2 = sh2.Cells(Rows.Count, 1).End(3).Row m = 2 If LR1 > 1 Then Union(sh1.Range("B2:B" & LR1), _ sh1.Range("D2:D" & LR1)).ClearContents End If For x = 2 To LR2 If sh2.Cells(x, 2).MergeCells Then t = sh2.Cells(x, 2).MergeArea.Rows.Count With sh1.Cells(m, 2) .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With x = x + t - 1: m = m + 1 Else With sh1.Cells(m, 2) .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With m = m + 1 End If Next End Sub الملف مرفق Naser.xlsm

لم أفهم ما تريده بالضبط!!! ماذا تمثل كل من 5.20 و 5.33؟

لن يستغرق تنسيق الفقرات على وورد 2010 أكثر من بضع ثواني. اضغط على السهم بجوار Paragraph بعد عمل تنسيق قبل الكتابة. غير Indentation أو المسافة البادئة إلى First Line.. https://typingpdf.blogspot.com/2020/02/Formatting-paragraphs-before-writing-in-word-2010.html

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

اخى العزيز الملف يفتح بسهولة كاى ملف تريد فتحه ولك شرح فيديو لكيفية فتح الملف