بحث مخصص من جوجل فى أوفيسنا
Custom Search
|
-
Posts
1,596 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
126
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
كل منشورات العضو محمد هشام.
-
البحث عن رقم ضمن رقم في متسلسلة بالاكسيل
محمد هشام. replied to Ahmed_J's topic in منتدى الاكسيل Excel
أخي كما سبق الذكر في المشاركة السابقة قد تم العمل فقط على مسألة إيجاد نفس القيمة وتلوينها بالنسبة للطلب الثاني صراحة لم أستوعب الفكرة لنفترض أنك كما جاء في الملف تبحث عن الرقم 260000 فهو موجود في 462499 كما ذكرت لاكن السؤال في حالة وجود الرقم 512499 فهو كذلك موجود بداخله ما هو العمل؟ -
اخي هناك فكرة قد تم تناولها مع احد الاخوة سابقا في احد المواضيع ربما تسهل عليك عملية التلوين بما ان الكلمات و الحروف مكررة يمكنك استخدام كود ينوب عنك في هده المسالة فقط ادخل اوقم بنسخ الكلمة او الحرف المطلوب في الخلية (F2) بنفس الشكل المكتوب به مثال : ( فَبَشِّرْهُم) لا يمكن كتابتها (فبشرهم) وسوف يتم تلوين جميع الكلمات دفعة واحدة مع الاحتفاظ بالتنسيق ..كما يمكنك تعديل رقم اللون المطلوب داخل الكود للون المطلوب كما في الصورة تحت Sub ChangeColor2() 'البحث في عمود("a") Application.ScreenUpdating = False Dim Rng As Range Dim MH As String Dim MH2 As String Dim x As Long Dim m As Long Dim y As Long Dim xFNum As Integer Dim xArrFnd As Variant Dim xStr As String MH = Range("F2").Value If Len(MH) < 1 Then Exit Sub xArrFnd = Split(MH, ",") ''' قم بتحديد النطاق المطلوب '''''' Range("A1:A100000").Select For Each Rng In Selection With Rng For xFNum = 0 To UBound(xArrFnd) xStr = xArrFnd(xFNum) y = Len(xStr) m = UBound(Split(Rng.Value, xStr)) If m > 0 Then MH2 = "" For x = 0 To m - 1 MH2 = MH2 & Split(Rng.Value, xStr)(x) '3= اللون الاحمر 'قم باستبدال الرقم 3 برقم اللون المطلوب .Characters(Start:=Len(MH2) + 1, Length:=y).Font.ColorIndex = 3 MH2 = MH2 & xStr Next End If Next xFNum End With Next Rng Range("F2").Select Application.ScreenUpdating = True End Sub قائمة الالوان اختر اللون المناسب وقم باستبداله داخل الكود في حالة تعدر عليك الامر يمكنك رفع الملف للتعديل فسوف نكون سعداء بمساعدتك في هدا العمل الطيب (فخِدْمَةَ الْقُرْآنِ مِنْ خَيْرِ الْأَعْمَالِ وَأَشْرَفِهَا، وَأَعْظَمِ الْقُرُبَاتِ وَأَعْلَاهَا، فَهُوَ خَيْرُ دَارٍ، وَحَسَنَاتٌ جَارِيَةٌ لِصَاحِبِهِ، حَيًّا وَمَيِّتًا.) ووفقنا الله واياكم اخي لما يحب ويرضى 4.xlsm
-
البحث عن رقم ضمن رقم في متسلسلة بالاكسيل
محمد هشام. replied to Ahmed_J's topic in منتدى الاكسيل Excel
تفضل اخي اليك طلبك Sub ChangeColor2() 'البحث في عمود("E") Application.ScreenUpdating = False Dim Rng As Range Dim MH As String Dim MH2 As String Dim x As Long Dim m As Long Dim y As Long Dim xFNum As Integer Dim xArrFnd As Variant Dim xStr As String MH = Range("F2").Value If Len(MH) < 1 Then Exit Sub xArrFnd = Split(MH, ",") Range("E1:E100000").Select For Each Rng In Selection With Rng For xFNum = 0 To UBound(xArrFnd) xStr = xArrFnd(xFNum) y = Len(xStr) m = UBound(Split(Rng.Value, xStr)) If m > 0 Then MH2 = "" For x = 0 To m - 1 MH2 = MH2 & Split(Rng.Value, xStr)(x) .Characters(Start:=Len(MH2) + 1, Length:=y).Font.ColorIndex = 3 MH2 = MH2 & xStr Next End If Next xFNum End With Next Rng Range("F2").Select Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''' 'البحث في عمود a,b Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("F2") Then cell.Interior.ColorIndex = 6 End If Next End Sub MH.xlsm -
البحث عن رقم ضمن رقم في متسلسلة بالاكسيل
محمد هشام. replied to Ahmed_J's topic in منتدى الاكسيل Excel
على حسب ما فهمت من طلبك المشكلة ليست مجرد البحث عن رقم معين وتلوينه على حسب ما جاء في طلبك الاول انت تبحث عن استخراج رقم موجود بين عددين وهدا موضوع اخر لم توضحه من قبل على العموم سيتم تعديل طلبك بالعثور على القيمة بشرط الخلية F2 الى حين توضيح المطلوب الثاني ..بالتوفيق -
البحث عن رقم ضمن رقم في متسلسلة بالاكسيل
محمد هشام. replied to Ahmed_J's topic in منتدى الاكسيل Excel
هذا سؤال آخر ليس له علاقة بطلبك الأول أخي وغير واضح!!!! -
البحث عن رقم ضمن رقم في متسلسلة بالاكسيل
محمد هشام. replied to Ahmed_J's topic in منتدى الاكسيل Excel
1- البحث عن طريق ادخال قيمة البحث في خلية معينة. 2- عند العثور على القيمة يذهب المؤشر الى الخليه التي فيها القيمة وتلوينها باللون الاصفر أخي قد تمت الاجابة بناءا على طلبك هذا !!!!! أما بالنسبة للمتسلسلة قد تم تجربتها هي كذلك . يتم تلوين محتوى الخلية بالكامل ربما أخي تقصد تلوين أرقام معينة داخل الخلية لأنك واضع المتسلسل (257500- 262449) في خانة واحدة...؟؟؟؟؟ -
وعليكم السلام ورحمة الله تعالى وبركاته نفضل اخي Private Sub CommandButton2_Click() Dim wbNew As Workbook Dim MH As String, ws As Worksheet Dim val As String Dim shape As Excel.shape MH = CStr(Sheets("الفاتورة").Range("B1")) val = Worksheets("الفاتورة").Range("a14") Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets("الفاتورة").Select Worksheets("الفاتورة").Copy Set wbNew = ActiveWorkbook With Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("a3").Select End With For Each shape In ActiveSheet.Shapes shape.Delete Next Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("A14").Value = val ActiveWorkbook.SaveAs Filename:= _ "C:\Users\edb3\Desktop\" & MH & "-" & "فاتورة رقم" & ".xlsx", FileFormat:=51 ActiveWorkbook.Close Sheets("الفاتورة").Activate Range("b1").Value = Range("b1").Value + 1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("a14").Formula = "=NumtoTxt(R[-1]C[6],""جنيهاً"",""قرشاً"")" Range("a3").Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Sub CommandButton3_Click() Range("b1").Value = Range("b1").Value + 1 Application.Dialogs(xlDialogPrinterSetup).Show ThisWorkbook.Sheets("الفاتورة").PrintOut copies:=1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents End Sub حفظ فاتورة.xlsm
- 1 reply
-
- 1
-
البحث عن رقم ضمن رقم في متسلسلة بالاكسيل
محمد هشام. replied to Ahmed_J's topic in منتدى الاكسيل Excel
تفضل اخي الكريم خلية البحث (G3) 'البحث في عمود A,B Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("g3") Then cell.Interior.ColorIndex = 6 End If Next End Sub ''''''''''''''''''''''''''''''''''''''''' ' E,البحث عن القيمة في متسلسلة عمود 'وتغيير لون الكتابة Sub FindLoop() Dim strFirstAddress As String Dim rngFindValue As Range Dim rngSearch As Range Dim rngFind As Range Set rngFind = ActiveSheet.Range("E1:E100000") Set rngSearch = rngFind.Cells(rngFind.Cells.Count) Set rngFindValue = rngFind.Find(Range("g3"), rngSearch, xlValues) If Not rngFindValue Is Nothing Then strFirstAddress = rngFindValue.Address rngFindValue.Font.Color = vbRed Do Set rngFindValue = rngFind.FindNext(rngFindValue) rngFindValue.Font.Color = vbRed Loop Until rngFindValue.Address = strFirstAddress End If End Sub 298667823_.xlsm -
السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار معيار الفلترة في خانة (D1) او ادخاله يدويا لفلترة جميع الاوراق على نفس المعيار Sub Filter_Me() Dim ans As String Dim T As ListObject MH = Sheets("Drawing").Range("D1") For i = 1 To Sheets.Count For Each T In Sheets(i).ListObjects T.Range.AutoFilter Field:=1, Criteria1:=MH Next Next End Sub ''''الغاء الفلترة من جميع الاوراق Sub Remove_Filters_From_Workbook() Dim MH As Worksheet Dim lstObj As ListObject For Each MH In Worksheets For Each lstObj In MH.ListObjects lstObj.AutoFilter.ShowAllData Next lstObj Next MH End Sub New Microsoft Excel Worksheet_MH.xlsm
-
وعليكم السلام ورحمة اللع تعالى وبركاته حاول اخي تضع نمودج او عينة للنتائج المتوقعة ومكان استخراجها لمزيدا من التوضيح
-
وعليكم السلام ورحمة الله تعالى وبركاته على ما يبدو لي المشكلة ليست في المعادلة .يمكنك اخي الفاضل الدخول الى الاعدادات والغاء تفغيل ظهور الاصفار كما في الصورة وبما انك لم تقم برفع الملف هدا مثال لطلبك تجربة.xlsx
- 1 reply
-
- 1
-
تفضل اخي https://streamable.com/dqdtjq
-
السلام عليكم ورحمة الله تعالى وبركاته .. اليك الاجابة والافادة معا . مع تعديل برنامجك ليتناسب مع طلبك . Private Sub Add_Click() '''''اضافة البيانات الى الليست بوكس''''' Dim MH As Variant, n As Byte If txtName.Value = Empty Then MsgBox "Please Enter Name": txtName.SetFocus: Exit Sub If txtJob.Value = Empty Then MsgBox "Please Enter Job": txtJob.SetFocus: Exit Sub If txtSallary.Value = Empty Then MsgBox "Please Enter Sallary": txtSallary.SetFocus: Exit Sub MH = Array(txtName.Value, txtJob.Value, txtSallary.Value, txtDate.Value) lstStItems.ColumnCount = 3 If lstStItems.ListCount <= 0 Then lstStItems.Column = MH Else lstStItems.AddItem MH(0) For n = 1 To 3 lstStItems.List(lstStItems.ListCount - 1, n) = MH(n) Next n End If txtName.Value = "" txtJob.Value = "" txtSallary.Value = "" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Fill_Click() '''''ترحيل البيانات من الليست بوكس الى التيكست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems txtName.Value = .List(.ListIndex, 0) txtJob.Value = .List(.ListIndex, 1) txtSallary.Value = .List(.ListIndex, 2) End With Else MsgBox " !المرجوا تحديد الصف ", vbCritical, "" End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Update_Click() '''''تعديل البيانات على الليست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems .List(.ListIndex, 0) = txtName.Value .List(.ListIndex, 1) = txtJob.Value .List(.ListIndex, 2) = txtSallary.Value End With Else MsgBox "!المرجوا تحديد الصف المراد تعديله ", vbCritical, "" End If End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Delete_Click() If lstStItems.ListIndex = -1 Then '''''حدف البيانات من الليست بوكس''''' MsgBox "!المرجوا تحديد الصف المراد حدفه !", vbCritical, "" Exit Sub End If If lstStItems.ListIndex >= 0 Then cevap = MsgBox("?هل انت متاكد من حدف البيانات", vbYesNo) If cevap = vbYes Then lstStItems.RemoveItem lstStItems.ListIndex End If End If End Sub Enter Data_MH.xlsm
-
وعليكم السلام ورحمة الله تعالى وبركاته ...تفضل اخي Sub creation_onglets_MH() Dim contenu As String Dim lig As Long, MH As Long Dim ws As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next For Each ws In Worksheets If ws.Name <> "data" Then ws.Delete Next ws With Sheets("data") MH = .Range("E" & Rows.Count).End(xlUp).Row For lig = 4 To MH contenu = .Cells(lig, 5).Value If contenu = "" Then GoTo Suite If FeuilleExiste(ThisWorkbook, contenu) Then .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) Else Sheets.Add ActiveSheet.Name = contenu .Rows(1).Copy Sheets(contenu).Range("A3") .Rows(lig).Copy Sheets(contenu).Range("A4") With .Range("A:E") .HorizontalAlignment = xlCenter Range("a:a").ColumnWidth = 5 Range("b:b").ColumnWidth = 28.71 Range("c:c,d:d").ColumnWidth = 10 Range("E:E").ColumnWidth = 13 Dim i For i = 4 To 100 If ws.Name <> "data" Then Rows(i).RowHeight = 33 End If Next i End With End If Suite: Next lig Sheets("data").Activate NbSheet = ActiveWorkbook.Sheets.Count Range([A3], [IV3].End(xlToLeft)).Select Set MaPlage = Selection [A1].Select For NS = 1 To NbSheet Set Destination = ActiveWorkbook.Sheets(NS).Range("A3") MaPlage.Copy Destination Next NS Sheets("data").Move Before:=Sheets(1) Application.DisplayAlerts = True Application.ScreenUpdating = True End With End Sub Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean On Error Resume Next FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing) End Function move row_MH.xlsm
-
تفضل اخي Private Sub CommandButton1_Click() Dim lr As Integer Dim ws As Worksheet Set ws = Sheet2 With ws lr = .Cells(Rows.Count, 3).End(xlUp).Row .Range("h" & lr + 1).Value = Me.TextBox1.Value .Range("f" & lr + 1).Value = Me.TextBox2.Value .Range("c" & lr + 1).Value = Me.TextBox3.Value End With Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox1.SetFocus End Sub 1محل.xlsm
-
مبروك الأستاذ Mohamed Hicham الترقية الى درجة خبير
محمد هشام. replied to Ali Mohamed Ali's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله تعالى وبركاته اتقدم بالشكر الجزيل الى ادارة الموقع والى جميع القائمين على هدا الصرح العريق - وعلى الثقة التي أوليتموني اياها. تعجز الحروف عن شكر ثقتكم وتواصلكم الراقي أرجو الله أن أكون عند حسن ظنكم وأن أقدم المفيد والمميز إن شاء الله. وانا سعيد جدا بانضمامي الى فريق الخبراء في هذا القسم وتحياتي لجميع الزملاء والاعضاء. وان شاء الله ان افيد واستفيد معكم -
السلام عليكم ورحمة الله تعالى وبركاته اليك حل اخر بالاكواد Sub Count_cells_if() Dim MH As Variant Dim ws As Worksheet Set ws = Worksheets("sh1") Range("A10:D10").ClearContents On Error Resume Next MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("a" & Application.WorksheetFunction.Match(Range("f3"), _ Range("a1:a9"), 0) & ":a9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("a10") = MH '''''''''''''''''''''''''''''''''''''''' MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("B" & Application.WorksheetFunction.Match(Range("f3"), _ Range("B1:B9"), 0) & ":B9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("B10") = MH '''''''''''''''''''''''''''''''''''''' MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("C" & Application.WorksheetFunction.Match(Range("f3"), _ Range("C1:C9"), 0) & ":C9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("C10") = MH ''''''''''''''''''''''''''''''''''''''''' MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("D" & Application.WorksheetFunction.Match(Range("f3"), _ Range("D1:D9"), 0) & ":D9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("D10") = MH On Error GoTo 0 End Sub ورقة عمل Microsoft Excel جديد (1).xlsm
-
وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي Private Sub CommandButton1_Click() Dim lr As Integer Dim ws As Worksheet Set ws = Sheet4 With ws lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("a" & lr + 1).Value = Me.TextBox2.Value .Range("b" & lr + 1).Value = Me.TextBox3.Value .Range("c" & lr + 1).Value = Me.TextBox4.Value .Range("d" & lr + 1).Value = Me.TextBox5.Value .Range("e" & lr + 1).Value = Me.TextBox6.Value End With Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox2.SetFocus End Sub
-
مساعدة فى برنامج لترحيل اكثر من صورة
محمد هشام. replied to walidelkholy's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله تعالى وبركاته اخي لم تحدد مكان وضع صورة البطاقة !!!!!...اما بالنسبة للصورة الشخصية يمكنك استخدام المعادلة التالية : =INDEX('ادخال البيانات'!$B$8:$C$300;EQUIV('فورم البيانات'!$B$10;'ادخال البيانات'!$C$8:$C$300;0);1) تجريبى.xls- 1 reply
-
- 2
-
Vlook or index or match dosn't give me what i want
محمد هشام. replied to احمد ديرو's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub Data_Transfer() On Error GoTo Fin Application.ScreenUpdating = False Dim MH%, MH2%, F MH = [A65500].End(xlUp).Row For Each F In Worksheets If F.Name <> "Input" Then With Sheets(F.Name) .Range("A1:E10000").ClearContents .Cells(1, 1) = F.Name: .Cells(1, 2) = "Kg": .Cells(1, 3) = "€" End With End If Next F For L = 2 To MH Feuille = Cells(L, "A") If Feuille = "" Then Exit Sub With Sheets(Feuille) .Cells(.[C65500].End(xlUp).Row + 1, 2) = Cells(L, 3) .Cells(.[C65500].End(xlUp).Row + 1, 3) = Cells(L, 5) End With Next L Exit Sub Fin: MsgBox "The sheet " & Cells(L, "A") & " does not exist." End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub clear() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "Input" Then ws.Range("a1:c1000").ClearContents End If Next ws End Sub Kopie von obst_MH.xlsm- 1 reply
-
- 1
-
@عبدالفتاح في بي اكسيل نعم استادنا الفاضل الفكرة في تعديل البرنامج لهده الدرجة هو توفير امكانية البحث للسائل بجميع الطرق الممكنة حيث يمكنه اظهار بيانات الفواتير المستحقة اليوم والمتاخرة عن ميعادها وايضا الفواتير التي لم يبلغ تاريخ استحقاقها رغم انه لم يتم طلبها . الا انني فكرت في تطوير برنامجه فقط