-
Posts
1,589 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
126
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
كل منشورات العضو محمد هشام.
-
وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_SelectionChange(ByVal Target As Range) StartColumn = 6 ' اول عمود LastColumn = 40 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn Application.ScreenUpdating = False If Range("b20").Value = "" Then Columns("F:H").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i End Sub كود اخفاء.xlsm
-
تفضل اخي ربما هدا ما تقصد Sub Test() Dim ws As Worksheet Dim rng As Range Dim cell As Range On Error GoTo Errorhandling Set ST = Sheet1 Set st2 = Sheet2 lr = ST.Range("H" & Rows.Count).End(xlUp).Row Sheet1.Range("B2:B" & lr).ClearContents st2.Visible = True Set rng = Range("H2:H" & lr) Application.DisplayAlerts = False Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then ws.Delete End If Next For Each cell In rng If cell <> "" Then Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = cell Range("i19").Value = ActiveSheet.Name End If Next cell Errorhandling: Sheet1.Activate Sheet1.Range("b2").Select For Each ws In ActiveWorkbook.Worksheets If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name ActiveCell.Offset(1, 0).Select Application.DisplayAlerts = True Application.ScreenUpdating = True End If Next ws st2.Visible = False End Sub
-
السلام عليكم ورحمة الله تعالى وبركاته ملاحظة :بعد ادن الاخوة الكرام بعد معاينة الكود الموجود في اليوزرفورم السائل ربما يقصد انشاء اوراق عمل جديدة طبق الاصل للورقة المخفية (sample) بشرط الاسماء الموجودة في عمود H شيت ( Vehicle ) واعادة تسميتها بنفس القيمة
-
لا لم انسى لاكن هدا ما فهمت من رسالتك الاخيرة على العموم تم اظافة المطلوب في المرفق التالي sella_V2.xlsm
-
وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام المعادلة التالية =IF(LEFT(TRIM(B2);1)="1";"س";"ج") ملف.xlsx
-
تفضل جرب اخي سعد هذا حل بواسطة اليوزرفورم sella_V1.xlsm
-
معيارين الصف والسنة فقط مع ترحيل البيانات إلى ورقة 2 صح؟
-
تمام ممكن تذكر لي المعايير التي تريد الفلترة بها. على حسب ما فهمت . الرقم القومي والصف والسنة والتحويل في حالة الرغبة بإضافة عنصر آخر يمكنك ذكره ملاحظة: ليس شرطا أن تقوم بفلترة البيانات على جميع المعايير. يمكنك اختيار ما تشاء مع امكانية الاشتغال على قوائم ديناميكية لتسهيل عملية الفلترة
-
في وجهة نظري بما أنك تريد الإختيار من القوائم.الافضل أنك تقوم بفلترة البيانات من خلال الشيت نفسه أو يوزرفورم صغير بالمعايير التي تريد وبالطريقة التي تحب سواءا فلترة الجدول نفسه أو على ليست بوكس ومن ثم ترحيلها مباشرة إلى شيت 2 !!! اذا وافقت على الفكرة يمكننا فعلها باذن الله
-
كيفية استبدال اكثر من كلمة بكلمة اخرى
محمد هشام. replied to حيدر البكري's topic in منتدى الاكسيل Excel
1)لم توضخ المطلوب جيدا هل هناك أسماء محددة تريد تغييرها. 2) هل التنفيذ على نطاق معين أو على الشيت بالكل Sub Replace() Dim sheet As Worksheet Dim Réf As Variant Dim val As String Dim y As Long Réf = Array("علي", "محمد", "احمد", "ضياء") val = "موظف" For y = LBound(Réf) To UBound(Réf) For Each sheet In ActiveWorkbook.Worksheets sheet.Columns("A:A").Replace What:=Réf(y), Replacement:=val, _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False Next sheet Next y End Sub لتنفيد الامر على جميع خلايا ورقة العمل يمكنك استبدال هذا الجزء من الكود sheet.Cells.Replace What:=Réf(y), Replacement:=val, _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False Next sheet Next y test.xlsm -
اخي حاول التأكد من نطاق الخلايا أو رفع عينة شبيهة للملف الخاص بك للوقوف وراء سبب عدم تنفيذ الكود على جميع الخلايا
-
Sub test2() lr = [b10000].End(xlUp).Row Range("B2:b" & lr).CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes End Sub صراحة لست متاكدا من المطلوب لاكن ما فهمت هو ازالة الصفوف عند التحقق من التكرار في جميع خلايا النطاق من العمود b الى h لاكن جملة الفاتورة المحددة تتضمن ربما تفسير اخر .هل تقصد تحديد رقم الفاتورة في خلية معينة مثلا او .....
-
السلام عليكم ورحمة الله تعالى وبركاته اليك اخي حل اخر بالاكواد Sub test() Dim ws As Worksheet Dim MOSS As Range Dim lr As Long Set ws = Worksheets("ورقة1") Application.ScreenUpdating = False lr = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row Set MOSS = ws.Range("A1:O" & lr) For Each ColorCell In MOSS If ColorCell <> "" Then ColorCell.Interior.Color = RGB(220, 230, 241) Else ColorCell.Interior.ColorIndex = xlNone End If Next End Sub مسودة تحذف.xlsm
-
وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب Sub Supprimer_la_ligne_en_double_B() Dim Rng As Range Dim X As Long Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp)) X = Rng.Rows.Count For X = X To 1 Step -1 With Rng.Cells(X, 1) If WorksheetFunction.CountIf(Rng, .Value) > 1 Then .EntireRow.Delete End If End With Next X End Sub حذف الفواتير المكررة.xlsm
-
ترحيل بيانات من جدول الى جدول حسب الاسم
محمد هشام. replied to saleem akhras's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله تعالى وبركاته. تفضل اخي ربما تقصد ترحيل البيانات بشرط الإسم الموجود في الخلية M3 اليك حل آخر بالمعادلات . INDIRET COSTS 2023_V1.xlsx -
تفضل جرب اخي اسم المستخدم: admin كلمة المرور : 12345 Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheet1 Dim lr As Long lr = sh.Range("A" & Rows.Count).End(xlUp).Row '''''''''''''''Validation''''''''' With sh .Cells(lr + 1, "A").Value = Me.TextBox2.Text .Cells(lr + 1, "B").Value = Me.TextBox3.Text .Cells(lr + 1, "C").Value = Me.TextBox4.Text .Cells(lr + 1, "D").Value = Me.TextBox5.Text .Cells(lr + 1, "E").Value = Me.TextBox6.Text .Cells(lr + 1, "F").Value = Me.TextBox7.Text .Cells(lr + 1, "G").Value = Me.TextBox8.Text .Cells(lr + 1, "H").Value = Me.TextBox9.Text .Cells(lr + 1, "i").Value = Me.TextBox10.Text .Cells(lr + 1, "j").Value = Me.TextBox11.Text .Cells(lr + 1, "k").Value = Me.TextBox12.Text End With For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i ListBox1.ColumnCount = 11 ListBox1.RowSource = "A1:K100000" MsgBox "تمت اضافة البيانات بنجاح" End Sub قاعدة بيانات1.xlsm
-
نعم اخي يمكنك دالك باضافة بسيطة للكود ليتم تنفيده فقط عند التغيير في عمود C Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C:C")) Is Nothing Then Set f = Sheet2 's("المخزن") Set m = Sheet1 's("البيانات") Application.ScreenUpdating = False Set MonDico = CreateObject("Scripting.Dictionary") For Each a In f.Range("C3", [C65000].End(xlUp)) If a <> "" Then MonDico(a.Value) = "" Next a With m.Range("C3:C65000") .ClearContents .Resize(MonDico.Count) = Application.Transpose(MonDico.keys) End With End If End Sub
-
نقل بيانات من ورقة عمل لأخرى بدون اصفار
محمد هشام. replied to ِAhmed mahmoud a's topic in منتدى الاكسيل Excel
السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاخوة الكرام اليك حل اخر على حسب ما فهمت من طلبك وهو نسخ الصفوف بشرط عدم وجود قيمة صفرية في جميع الخلايا من العمود F الى N Sub CopyData() Dim x, i As Long, j As Long, MH As Long, n As Long Dim st As Worksheet, WS As Worksheet, s As String Application.ScreenUpdating = False Set st = Sheets("Budget 2023") MH = st.Range("D" & Rows.Count).End(xlUp).Row x = st.Range("D1:N" & MH) ReDim Preserve x(1 To UBound(x), 1 To UBound(x, 2) + 1) For i = 1 To UBound(x) For j = 3 To UBound(x, 2) - 1: x(i, UBound(x, 2)) = x(i, UBound(x, 2)) & x(i, j): Next j Next i Set WS = Sheets("résultat") WS.Range("A:K").ClearContents For i = 1 To UBound(x) If x(i, UBound(x, 2)) <> 0 Then n = n + 1 For j = 1 To UBound(x, 2): x(n, j) = x(i, j): Next End If Next With WS.Range("A1").Resize(n, UBound(x, 2) - 1) .Value = x .HorizontalAlignment = xlCenter '.BorMHs.LineStyle = xlContinuous End With End Sub Budget 2023_v1.xlsb -
ضعه بحدث شيت المخزن بهذه الطريقة اخي ' Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set f = Sheet2 Set m = Sheet1 Application.ScreenUpdating = False f.Activate Set MonDico = CreateObject("Scripting.Dictionary") For Each a In f.Range("C3", [C65000].End(xlUp)) If a <> "" Then MonDico(a.Value) = "" Next a With m.Range("C3:C65000") .ClearContents .Resize(MonDico.Count) = Application.Transpose(MonDico.keys) End With End Sub V3_تصفية بيانات المخزن (1).xlsm
-
وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub SansDoublons() Set f = Sheets("المخزن") Set M = Sheets("البيانات") Application.ScreenUpdating = False Set réf = CreateObject("Scripting.Dictionary") A = Range(f.[C3], f.[C65000].End(xlUp)).Value For Each c In A réf(c) = "" Next c Set dest = M.Range("C3") dest.Resize(réf.Count, 1) = Application.Transpose(réf.keys) ' ترتيب ابجدي dest.Resize(réf.Count, 1).Sort Key1:=dest, Order1:=xlAscending Set réf = Nothing End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'في حالة الرغبة بوضع الكود في حدث الشيت Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C:C")) Is Nothing Then Set f = Sheets("المخزن") Set M = Sheets("البيانات") Set réf = CreateObject("Scripting.Dictionary") A = Range(f.[C3], f.[C65000].End(xlUp)).Value For Each c In A réf(c) = "" Next c Set dest = M.Range("C3") dest.Resize(réf.Count, 1) = Application.Transpose(réf.keys) dest.Resize(réf.Count, 1).Sort Key1:=dest, Order1:=xlAscending Set réf = Nothing End If End Sub V1_تصفية بيانات المخزن .xlsm
-
السلام عليكم ورحمة الله تعالى وبركاته نظرا لحجم اليوزرفورم الكبير وصعوبة التعامل معه قد تم الاشتغال على النسخة الاولى للفورم . واضافة المطلوب يمكنك تكييف الامور بما يناسبك طلب وتعديل يوزيرفورم 4.xlsm
-
وعليكم السلام ورحمة الله تعالى وبركاته اليك حل اخر =IF(A5<>"";DATE(YEAR(A5);MONTH(A5);DAY(A5)+1);"") '''''''''''''''''''''''''''''''''' =IF(A5<>"";DATE(YEAR(A5)+1;MONTH(A5);DAY(A5)-1);"") تاريخ.xlsx
-
وعليكم السلام ورحمة الله تعالى وبركاته arr = SH.Range("A5:H" & SH.Cells(Rows.Count, 1).End(xlUp).Row).Value2
-
VLookUp اثناء اسخدام دالة #N/A مشكلة الــ
محمد هشام. replied to Noon1's topic in منتدى الاكسيل Excel
=IFERROR(VLOOKUP(@$A$2:$A$6,Sheet2!$A$1:$B$6,2,0),"") -
دمج عددة ملفات بنفس الاسم من أكثر من فولدر
محمد هشام. replied to Ahmed Saad 2017's topic in منتدى الاكسيل Excel
وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اليك برامج هدية لك ولكل اعضاء وزوار منتدى اوفيسنا . ملف تم تعديله بطريقة دينامكية تمكنك من دمج اكثر من 100 ملف في مجلدات مختلفة في ملف واحد . رابط لشرح طريقة الاستخدام بالتوفيق............ Sh_2023.zip