اذهب الي المحتوي
أوفيسنا

محمد هشام.

الخبراء
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    1,589

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    126

 نوع المحتوي 

كل منشورات العضو محمد هشام.

  1. محمد هشام.
    وعليكم السلام ورحمة الله تعالى وبركاته اظن ان المشكلة لديك من المعادلات المستخدمة لجلب البيانات ادا كنت تستخدم نسخة 2021 او ما فوق يمكنك حدف جميع الصيغ الموجودة على اوراق العمل والاكتفاء بوضع الصيغة التالية في اول خلية لديك على عمود C فقط مع مراعات الفواصل المنقوطة على حسب النسخة لديك =FILTER('All Customers'!$C$4:$G$1000;'All Customers'!$E$4:$E$1000=REPLACE(CELL("filename";$A$4);1;FIND("]";CELL("filename";$A$4));"")) 'OR =FILTER('All Customers'!$C$4:$G$1000,'All Customers'!$E$4:$E$1000=REPLACE(CELL("filename",$A$4),1,FIND("]",CELL("filename",$A$4)),"")) ترحيل البيانات حسب اسم الشيت الاصل.xlsx
  2. محمد هشام.
    اخي خلفية اليوزرفوم عبارة عن صورة لا يمكن جلب لونها الا الشريط المتحرك ربمايمكنك تحديد لون يشبه لون الصوة مثلا body BGCOLOR ='&003366' وتعديل حجم الكتابة' بما يناسبك مثلا size='20 Private Sub UserForm_Initialize() Dim LaCouleur As String Dim Te LaCouleur = xlThemeColorLight1 Te = ("برنامج المخازن يرحب بكم . صل على محمد ") Me.WebBrowser1.Navigate _ "about:<html><body BGCOLOR ='&003366' scroll='no'><font color= " & LaCouleur & " size='20' face='NEW'>" & _ "<marquee direction=right>" & Te & "</marquee></font></body></html>" End Sub
  3. محمد هشام.
    تفضل تم التعديل مع اظافة اكواد جديدة اظن انك باستطاعتك تعديلها بما يناسبك للحصول على النتائج المتوقعة لانني غير متاكد من قيمة العمود 3 على الليست بوكس 1 هل تود ترحيل قيمة المخزون او الكمية اليك الكود المستخدم في حالة الرغبة بالتعديل Private Sub CommandButton1_Click() '''''اضافة البيانات الى الليست بوكس''''' Dim b As Variant, n As Byte If catetr <> "" And Me.TextBox1 <> "" Then If Quantitetr.value = Empty Then MsgBox "المرجوا ادخال الكمية": Quantitetr.SetFocus: Exit Sub ' ترتيب التيكست بوكس b = Array(Me.CB_Pièce.value, Me.catetr.value, Me.Quantitetr.value, TextBox1.value) If ListBox1.ListCount <= 0 Then ListBox1.Column = b Else ListBox1.AddItem b(0) For n = 1 To 4 ListBox1.List(ListBox1.ListCount - 1, n) = b(n) Next n End If Me.ListBox1.ColumnCount = 4 Me.ListBox1.ColumnWidths = "55;55;55;55" End If End Sub sell-the-first-quantity- V4 .xlsm
  4. محمد هشام.
    تفضل جرب هل هدا ما تقصده تم تمييز الاظافات التي قمت بتعديلها داخل الاكواد يرجى مراجعتها وتعديلها بما يناسبك sell-the-first-quantity- V3.xlsm
  5. محمد هشام.
    ببساطة يمكنك اظافة السطر التالي في اخر الكود مع تعديل تنسيق التاريخ بما يناسبك 'Private Sub UserForm_Initialize() 'Code........... For i = LBound(OneRng) To UBound(OneRng): OneRng(i, 9) _ = Format(OneRng(i, 9), "dd/mm/yyyy"): Next i End sub للاسف لا استطيع فهم طلبك ومادا تقصد بقيمة المخزون
  6. محمد هشام.
    وعليكم السلام ورحمة الله تعالى وبركاته جرب وضع الوظيفة التالية في : Module Option Explicit Function Xformula(Search_string As String, _ Cpt As Range, Cnt As Range) Dim i As Long Dim lig As String For i = 1 To Cpt.Count If Cpt.Cells(i, 1) = Search_string Then lig = lig & " " & Cnt.Cells(i, 1).Value End If Next Xformula = Trim(lig) End Function وفي الخلية E3 ضع المعادلة التالية مع سحبها للأسفل =@Xformula(A3;Sheet1!$A$2:$A$200;Sheet1!$D$2:$D$200) sumifs.xlsb
  7. محمد هشام.
    Copy of sell-the-first-quantity- V3.xlsm
  8. محمد هشام.
    صراحة لم افهم طريقة اشتغالك على الملف لاكنني حاولت فقط انشاء الكود الخاص بالفلترة ما بين العناصر المدكورة على يوزرفورم مستقل يمكنك اظافة الاكواد الخاصة بك معه او تعديله بما يناسبك Option Compare Text Dim OneRng(), Rng, rCrit1, rCrit2 Private Sub UserForm_Initialize() Set f = Sheets("Stock") OneRng = f.Range("A4:I" & f.[A65000].End(xlUp).Row).value Rng = UBound(OneRng, 2) ' اسم المخزن rCrit1 = 5 'كود الصنف rCrit2 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit1)) = "" Next i rw = d.keys Me.ComboBox1.List = rw Me.ComboBox1.ListIndex = 0 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.keys Me.CB_Pièce.List = rw Me.CB_Pièce.ListIndex = 0 End Sub Private Sub ComboBox1_click() Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) If OneRng(i, rCrit1) = Me.ComboBox1 Then _ d(OneRng(i, rCrit2)) = "" Next i rw = d.keys Me.CB_Pièce.List = rw: Me.CB_Pièce.ListIndex = 0 Filtre End Sub Sub Filtre() Dim Tbl() Cpt1 = Me.ComboBox1: Cpt2 = Me.CB_Pièce N = 0 For i = 1 To UBound(OneRng) If OneRng(i, 5) Like Cpt1 And OneRng(i, 1) Like Cpt2 Then N = N + 1: ReDim Preserve Tbl(1 To Rng, 1 To N) For K = 1 To Rng: Tbl(K, N) = OneRng(i, K): Next K End If Next i If N > 0 Then Me.ListBox2.Column = Tbl Else Me.ListBox2.Clear End If If Me.ComboBox1 = "*" And _ Me.CB_Pièce = "*" Then Me.ListBox2.Clear End Sub Private Sub CB_Pièce_click() Filtre End Sub Copy of sell-the-first-quantity- V2.xlsm
  9. محمد هشام.
    العفو اخي @Chenine Abdelhalim يسعدنا اننا استطعنا مساعدتك
  10. محمد هشام.
    اخي بعد معاينة ورقة العمل الخاص بك لاحظت ان الخلفية الزرقاء هي في الاصل اسم النطاق المسمى Name_Rang0 قم بحدفه وتنظيف ورقة العمل من النطاقات والتنسيقات الغير مستخدمة وستختفي معك الخلفية بادن الله اليك الملف بعد حدف جميع النطاقات الغير مستخدمة والخاطئة مع البقاء على التنسيق الشرطي كما كان من قبل New ورقة عمل Microsoft Excel.xlsb
  11. محمد هشام.
    حاول تجربة وضع هدا في اخر الكود sh.Range("C10:C" & sh.Rows.Count).NumberFormat = "0" 'OR sh.Columns(3).NumberFormat = "0" المفروض انك تحدد العمود بالكامل وتغيير التنسيق دفعة واحدة
  12. محمد هشام.
    لا يمكنني اخي الفاضل تخمين دالك بدون معاينة الملف حاول ارفاقه ادا كان دالك ممكنا بالنسبة لك لنتمكن من تحديد السبب وراء عدم اشتغال الكود معك
  13. محمد هشام.
    النتيجة V2.xlsm
  14. محمد هشام.
    تفضل اخي نفس الفكرة سيتم انشاء مجلد في نفس مسار المصنف باسم ملفات word وحفظ الملفات بداخله تمت اظافة الاكواد على الشيتات المطلوبة Sub ExcelToWordSheet1() Dim lr As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Msg = MsgBox("؟" & " " & "Word " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub On Error Resume Next Dim docDest As Word.Document Dim srcWS As Word.Application Set srcWS = CreateObject("word.application") srcWS.Visible = True xName = "ملفات Word" XPath = ThisWorkbook.path & "\" & xName lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row WS.Range("A7: k" & lr).Copy Set docDest = srcWS.Documents.Add srcWS.Selection.PasteExcelTable _ LinkedToExcel:=False, WordFormatting:=False, RTF:=False Application.CutCopyMode = False srcWS.ActiveDocument. _ PageSetup.Orientation = wdOrientLandscape srcWS.ActiveDocument. _ PageSetup.PaperSize = WdPaperSize.wdPaperA3 If Dir(XPath, vbDirectory) = "" Then MkDir XPath docDest.SaveAs XPath & "\" & WS.Name & ".docx" docDest.Close Set docDest = Nothing srcWS.Quit Set srcWS = Nothing MsgBox "Done", vbInformation End Sub ملاحظة في حالة قمت بنسخ الاكواد الى ملف اخر لا تنسى تفعيل الخاصية التالية 2025 v2.xlsm
  15. محمد هشام.
    ادا كنت قد فهمت طلبك بشكل صحيح فهدا سيوفي بالغرض Sub CopyRanges() Dim i As Long, r As Long, a As Long, lr As Long Dim OneRng As Variant, arr As Variant Dim WS As Worksheet: Set WS = Sheets("شيت") Dim f As Worksheet: Set f = Sheets("نتيجةت1") a = WS.Range("A" & WS.Rows.Count).End(xlUp).Row lr = f.Columns("D:AD").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Application.ScreenUpdating = False For r = 14 To lr Union(f.Range("D" & r).Resize(, 14), f.Range("S" & r).Resize(, 12)).ClearContents Next r OneRng = Array("H8:I" & a, "L8:M" & a, "P8:Q" & a, "T8:U" & a, _ "X8:Y" & a, "AB8:AC" & a, "AF8:AG" & a, "AH8:AQ" & a, "AT8:AU" & a) arr = Array("D14", "F14", "H14", "J14", "L14", "N14", "P14", "S14", "AC14") For i = 0 To UBound(OneRng) WS.Range(OneRng(i)).Copy f.Range(arr(i)).PasteSpecial xlPasteValues Next Application.ScreenUpdating = True Application.CutCopyMode = False End Sub وفي ورقة (نتيجةت1) Private Sub Worksheet_Activate() CopyRanges End Sub New ورقة عمل Microsoft Excel .xlsb
  16. محمد هشام.
    هل من الممكن ارفاق عينة للنتائج المتوقعة مع دكر ما هو شرط تنفيد الكود هل هو ادخال اسم الطالب مثلا في عمود اسـم التلميــــذ او مادا
  17. محمد هشام.
    وفيك بارك الله اخي أحمد يوسف هده من مهام المشرفين والقائمين على المنتدى ليس لي اي دراية بها
  18. محمد هشام.
    وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب اظنه اسرع Sub TEST1() Dim WS As Worksheet, sh As Worksheet Set WS = Sheets("Feuil5"): Set sh = Sheets("Feuil6") LR = WS.Cells(Rows.Count, 3).End(xlUp).Row Application.ScreenUpdating = False sh.Range("A10:M" & sh.Rows.Count).ClearContents a = WS.Range("A10:K" & LR).Value Dim tmp(): ReDim tmp(1 To UBound(a)) For I = LBound(a) To UBound(a) On Error Resume Next If a(I, 2) = sh.[E3] And a(I, 11) = sh.[F3] Then n = n + 1: tmp(n) = I ' بما ان رموز الفواتير ثابثة بين 0 . و 1 اجعل الشرط بهده الطريقة ' If a(I, 2) = sh.[E3] And a(I, 11) >0 Then n = n + 1: tmp(n) = I Next ReDim Preserve tmp(1 To n) a = Application.Index(a, Application.Transpose(tmp), _ Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")"))) sh.[A10].Resize(UBound(a), UBound(a, 2)) = a Application.ErrorCheckingOptions.BackgroundChecking = False Application.ScreenUpdating = True End sub حساب العملاء 2024.xlsm
  19. محمد هشام.
    تفضل اخي تم استبدال الكود ليتناسب مع متطلباتك الحالية مع دمج الاكواد السابقة في نفس الملف Sub CopyData2() Dim x&, OneRng As Range, rCrit As String Dim srcWS As Worksheet, WS As Worksheet Dim i As Long, lrow As Long Set srcWS = Sheets("Data") Set WS = Sheets("FORM3"): rCrit = WS.[G2].Value 'قم بتعديل كود التفقيط بما يناسبك Const iCnt As String = "=IFERROR(@NombreToArabe(E9),"""")" If IsEmpty(WS.[G2].Value) Then: Exit Sub Set OneRng = srcWS.Columns(3).Find(What:=rCrit, LookIn:=xlValues, LookAt:=xlWhole) If OneRng Is Nothing Then MsgBox rCrit & " : " & "غير موجودة", vbInformation: Exit Sub Else Application.ScreenUpdating = False lrow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For i = 11 To lrow Union(WS.Range("C" & i), WS.Range("E" & i)).ClearContents Next i x = OneRng.Row WS.[A9] = srcWS.Cells(x, 1) 'الرقم WS.[B9] = srcWS.Cells(x, 2) 'رقم صفحة WS.[C9] = srcWS.Cells(x, 3) 'نوع اللوازم و مواصفاتها WS.[D9] = srcWS.Cells(x, 4) 'رصيد السجل WS.[E9] = srcWS.Cells(x, 33) 'المجموع With WS.[F9] 'العدد كتابة .Formula = [iCnt]: .Value = .Value End With tmp = srcWS.Range("A4:AF" & srcWS.Cells(Rows.Count, 3).End(xlUp).Row).Value2 Dim a(): ReDim a(1 To UBound(tmp) * UBound(tmp, 2), 1 To 5) n = 0 For ligne = 1 To UBound(tmp, 1) For Col = 6 To UBound(tmp, 2) If tmp(ligne, 3) = rCrit And tmp(ligne, Col) <> "" Then n = n + 1 a(n, 2) = tmp(1, Col) 'رؤوس الاعمدة a(n, 4) = tmp(ligne, Col) ' رصيد الغرف المتوفرة End If Next Col Next ligne WS.Cells(k + 11, 2).Resize(n, 3 + 1) = a IRow = WS.Cells(Rows.Count, "E").End(xlUp).Row + 1 WS.[F11] = Application.Sum(WS.Range("E11:E" & IRow)) ' مجموع عمود الرصيد End If Application.ScreenUpdating = True End Sub لقد لاحظت انك لديك القدرة لفهم الاكواد من خلال التعديلات التي قمت بها على الاقتراحات السابقة . حاولت توضيح بعض النقط المهمة على الكود ليسهل عليك التعديل على حسب احتياجاتك مستقبلا. بالتوفيق ..... DATA V4.xlsb
  20. محمد هشام.
    تمام اخي بما انك توصلت للنتيجة المتوقعة بخصوص الطلب الاول يفضل غلق الموضوع اما بخصوص طلبك الثاني ساقوم بنشره بادن الله في مكانه الصحيح بعد اظافة ورقة FROM3
  21. محمد هشام.
    لقد لاحظت انك قمت بفتح موضوع جديد بالطلب الثاني خطوة جيدة لاكن يبدو اننا بحاجة لانهاء الموضوع الاول وغلقه للمررور للطلب الثاني بادن الله بعد معاينة بعض التعاليق التي قمت انت باظافتها على الكود لاحظت انك ترغب بجلب بيانات عمود الغرفة المحددة الى عمود الرصيد ورقة FORM2 كان بوسعنا فعل دالك لو حاولت شرح طلبك بشكل اكثر وضوحا على ما اعتقد وقبل المرور للطلب الثاني قم بتجربة الكود التالي ووافينا بالنتيجة .. Sub CopyData() '“Update the code Dim OneRng As Range, r As Range, rw As Long, lastrow As Long Dim srcWS As Worksheet: Set srcWS = Sheets("Data") Dim WS As Worksheet: Set WS = Worksheets("FORM2"): rCrit = WS.[G5] '“Adjust the formula to suit you Const iCnt As String = "=IFERROR(@NombreToArabe(E9),"""")" '“Room search scope Set r = srcWS.Range("A4:AH4").Find(rCrit) If IsEmpty(WS.[G5].Value) Then: Exit Sub rw = srcWS.Columns("A:AH").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Not r Is Nothing Then With srcWS '“Set range (starting cell 5 of target column) Set OneRng = .Range(.Cells(5, r.Column), .Cells(rw, r.Column)) If WorksheetFunction.CountA(OneRng) = 0 Then: _ MsgBox "لا تتوفر نتائج على" & " : " & rCrit, vbInformation, _ "Information :": Exit Sub End With Application.ScreenUpdating = False WS.Range("A9:F" & WS.Rows.Count).ClearContents With srcWS If .AutoFilterMode Then .AutoFilterMode = False End With '“Column headers With srcWS.Range("A4:AH4") .AutoFilter r.Column, "<>" '(1)“If the columns are not adjacent ' rngA = Split("A,B,C,D", ",") ' rngB = Split("A,B,C,D", ",") ' For i = LBound(rngA) To UBound(rngA) With srcWS '(2) '.Range(rngA(i) & "5:" & rngA(i) & rw).Copy ' WS.Range(rngB(i) & "9").PasteSpecial Paste:=xlPasteValues '“From column ("A") to ("D") .Range("A5:D" & rw).SpecialCells(xlCellTypeVisible).Copy WS.Range("A9").PasteSpecial Paste:=xlPasteValues 'Copy the target column data .Range(.Cells(5, r.Column), _ .Cells(rw, r.Column)).SpecialCells(xlCellTypeVisible).Copy WS.Range("E9").PasteSpecial Paste:=xlPasteValues End With '(3) Next i .AutoFilter End With With WS '“Add the formula to the column of numbers in writing ("F") lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row With WS.Range("F9:F" & lastrow) .Formula = [iCnt]: .Value = .Value End With End With End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub يمكنك تعديل الكود بما يناسبك DATA V2-1.xlsb
  22. محمد هشام.
    اخي طلبك غير واضح بالنسبة لي ما هي علاقة الغرفة 1 بالمادة 13 مثلا !!!!!!!!!!!! حتى لو قمت بتجربة الدهاب الى عمود الغرفة 1 وقمت بفلترتها على الخلايا الغير فارغة لن تجد غرفة 13 في عمود (نوع اللوازم و مواصفاتها ) ربما يجب عليك اعادة صيغة طرح طلبك مع مزيدا من التوضيح او ارفاق عينة للنتائج المتوقعة المرجوا جعل كل طلب في موضوع مستقل
  23. محمد هشام.
    وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim A As Range For Each A In Range("M3:P28") If Not IsError(A) Then Application.ScreenUpdating = False Application.EnableEvents = False If A.Interior.ColorIndex <> xlNone Then A.Offset(0, -9).Interior _ .ColorIndex = A.Interior.ColorIndex Else A.Offset(0, -9).Interior.ColorIndex = xlNone End If End If Next A Application.ScreenUpdating = True Application.EnableEvents = True End Sub Book1 V2.xlsb
  24. محمد هشام.
    وعليكم السلام ورحمة الله تعالى وبركاته Sub CopyData() Dim srcWS As Variant, _ WS As Worksheet, _ r As Range, _ OneRng As Range, rCrit As String Set srcWS = Sheets("Data") Set WS = Sheets("FORM2"): rCrit = WS.[G5] Const iCnt As String = "=IFERROR(@NombreToArabe(E9),"""")" Set r = srcWS.Range("A4:AH4").Find(rCrit) Cpt = Array(2, 3, 4, 33) With Application .Calculation = xlCalculationManual .ScreenUpdating = False If IsEmpty(WS.[G5].Value) Then: Exit Sub rw = srcWS.Cells(srcWS.Rows.Count, "B").End(xlUp).Row If Not r Is Nothing Then With srcWS Set OneRng = .Range(.Cells(5, r.Column), .Cells(rw, r.Column)) If WorksheetFunction.CountA(OneRng) = 0 Then: _ MsgBox "لا تتوفر نتائج على" & " : " & rCrit, vbInformation: Exit Sub End With WS.Range("A9:F" & WS.Rows.Count).ClearContents a = srcWS.Range("A5:AH" & srcWS.[A65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, r.Column) <> "" Then WS.Cells(F + 9, 2).Resize(, 4) _ = Application.IfError(Application.Index(a, i, Cpt), "") F = F + 1 End If Next With WS lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row With WS.Range("F9:F" & lastRow) .Formula = [iCnt]: .Value = .Value With WS.Range("A9:A" & lastRow) .Value = Evaluate("ROW(" & .Address & ")-8") End With End With End With End If .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub تمت اظافته للملف المرفق بالتوفيق ....... DATA V2.xlsb
  25. محمد هشام.
    جرب هدا test.xlsx
×
×
  • اضف...

Important Information

  I accept