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

Public Sub CopyData2() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") ' خلية البداية Col_Star = 10 '(R) عمود الشرط Col_Search = 18 'الشرط الاول(الفصل) Clé1 = desWS.[R12] 'الشرط الثاني (المادة) Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False 'التحقق من وجود قيمة في خلايا الشرط If Len(Clé1) > 0 And Len(Clé2) > 0 Then ' افراغ البيانات السابقة desWS.Range("C14:U" & Rows.Count).ClearContents ' اسماء الاوراق المستهدفة Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSdata = Sheets(Sh(i)) With WSdata ' الغاء الفلترة .AutoFilterMode = False ' Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' النطاق Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow ' في حالة تحقق الشرط الاول If WSdata.Cells(Rng, Col_Search).Value = Clé1 Then 'عمود (C) تحديد اخر صف عليه بيانات rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row ' الاعمدة المرغوب جلب بياناتها Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) ' لصق البيانات بعد اخر قيمة من عمود (C) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSdata.Cells(Rng, Cpt(c)).Value Next c End If Next Rng ' فلترة جميع الاوراق على الشرط الاول rngFound.AutoFilter Field:=16, Criteria1:=Clé1 ' البحث في الصف 9 عن الشرط الثاني (المادة) Set rngSearch = WSdata.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then 'نسخ بيانات العمود rngSearch.Offset(1).Resize(ligne - 1).Copy ' لصق بعد اخر خلية من عمود (U) desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'الغاء الفلترة rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub

وجدتها يا شباب الخاصية هذه تتأكد فقط ( ويختفي الاطار كليا ) عندما نعمل اختصار لقاعدة البيانات سواء على سطح المكتب او غيره نفتح على خصائص الاختصار : لسان التبويب اختصار او shortCut ثم حقل تشغيل او run نغير الى تصغير النتيجة : الاطار يظهر فقط عند تشغيل قاعدة البيانات مباشرة

لها حل اخي الكريم ، ولكن اعذرني ليوم الغد إن شاء الله 😊

يا ليت عندي الحل يا بو خليل لأرد لك شيء مما قدمت لي الكل يتمنى يقدم لك ولأمثالك أي مساعدة

أدخلت تعديل على الدالة ولكن هي تعمل بنفس الأسلوب التعديل أن تعطي القيمة "" في حالة عدم وجود وحدة القياس وتعطي الناتج بالسالب في حالة لم يجد نفس الوحدة. صاحب الموضوع يا أنه تاه أو أنه مل، إن شاء الله يرجع لنا سريعا. Function getBalance(DumpVal) As Variant Dim sht1 As Worksheet, main As Worksheet Dim lrow As Integer, row As Integer Dim unit As String Set sht1 = Sheets("ورقة1") Set main = Sheets("رئيسي ") getBalance = "" With sht1 lrow = .Range("B1").End(xlDown).row unit = Trim(.Cells(lrow, 3)) If unit = "" Then Exit Function getBalance = -.Cells(lrow, 2) End With With main lrow = .Range("B1").End(xlDown).row For row = lrow To 2 Step -1 If .Cells(row, 1) Like "*" & unit Then getBalance = .Cells(row, 2) + getBalance Exit For End If Next row End With Set sht1 = Nothing Set main = Nothing End Function getBalance_07.xlsm

وعليكم السلام 🙂 ممكن تستخدم هذا الكود لتوحيد الحروف ثم تبحث : دالة لاستبدال الحروف العربية المتشابهة إلى حرف واحد وذلك لاستخدامها في عمليات البحث وتلافي أخطاء الكتابة الكود: Public Function ReplaceArabicLetters(strText As Variant) As String ' استبدال الحروف العربية المتشابهة إلى حرف واحد وذلك لاستخدامها في عملية البحث وتلافي أخطاء الكتابة ' أ،إ،ا =(تحول إلى)=> ا ' ي،ى =(تحول إلى)=> ي ' ـه،ـة =(تحول إلى)=> ـه ' Moosak strText = Nz(strText, "") strText = Replace(strText, "أ", "ا") strText = Replace(strText, "إ", "ا") strText = Replace(strText, "آ", "ا") strText = Replace(strText, "ى", "ي") strText = Replace(strText, "ة", "ه") ReplaceArabicLetters = strText End Function طريقة الاستدعاء (الاستخدام): ReplaceArabicLetters("أجمل إنسان إللي معه ربطة فلوس وأعطى زملائه كلهم") النتيجة : ==> اجمل انسان اللي معه ربطه فلوس واعطي زملائه كلهم

وعليكم السلام ورحمة الله وبركاته ليس لدي 2010 لكن شغال على 2016 بدون مشاكل مع اخفاء شاشة الاكسس تظهر الصورة المختارة .

عليكم السلام لست بحاجة لمرفقات اجعل معيار البحث بين تاريخين يشبه هذا Between Nz([forms]![frmSearch]![txtStartDate],"01/01/1300") And Nz([forms]![frmSearch]![txtEndDate],"01/01/2100") ومعيار مربع التحرير يشبه هذا Like "*" & [forms]![frmSearch]![combo1] & "*"

هذا ما كنت اريده تم الحل شكرا وجزاك الله خيرا

يبدو أن الأستاذ محمد هشام فهم ما فهمته أنا أيضا لأن معادلته تعطي نفس ناتج دالتي. لقد قمت بالتعديل على الدالة بتمرير قيمة مهملة فقط لتشعر بأي تغيير في الصفحتين وتقوم بالحساب الذاتي. Function getBalance(DumpNum) As Long getBalance = Sheets("رئيسي ").Range("B1").End(xlDown) - _ Sheets("ورقة1").Range("B1").End(xlDown) End Function getBalance_02.xlsm

جرب هذا الكود ، مع تعديل مربع النص الذي به الرقم المتسلسل Dim W As Object Set W = CreateObject("Word.Application") W.Documents.Open "C:\Users\MH\Desktop\test.docx" W.Visible = True W.ActiveDocument.bookmarks("txtname").Select W.Selection.InsertAfter Me.nname.Value W.ActiveDocument.bookmarks("txtarea").Select W.Selection.InsertAfter Me.area.Value W.ActiveDocument.bookmarks("txttele").Select W.Selection.InsertAfter Me.tele.Value ' تم إضافة السطر التالي لحفظ ملف الورد برقم المسلسل W.ActiveDocument.SaveAs "C:\Users\MH\Desktop\" & Me.SerialNumber.Value & ".docx"

تفضل اخي حاولت قدر الامكان اختصار الكود بطريقة ابسط نوعا ما ليسهل التعامل معه والتعديل عليه للضرورة مع توضيح بعض النقاط المهمة Sub GetPrice3() Dim WSitems As Worksheet, WSPrice As Worksheet, dest As Worksheet, ws As Worksheet Dim s As Range, Title As Range, r As Range, Rng As Range, ShtDate As Date, MaxDate As Date Dim c As Range, f As Range, a&, XPric As String, Clé As Range Set WSitems = ThisWorkbook.Sheets("items") Set dest = Worksheets("itemout") 'B4 'استخراج اسم قائمة الاسعار بشرط التاريخ المدخل في الخلية XPric = dest.Range("E4"): Set Title = dest.[B8:B32] If Len(dest.Range("B4").Value) = 0 Then: MsgBox "يجب عليك إدخال التاريخ", vbExclamation: Exit Sub If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= dest.Range("B4").Value And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & dest & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else 'تعريف الورقة الهدف Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) End If End If 'التحقق من ادخال كود الصتف If Application.WorksheetFunction.CountA(dest.Range("B8:B32")) = 0 Then MsgBox "المرجوا ادخال كود الصنف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin" Exit Sub End If With Application .EnableEvents = False .ScreenUpdating = False If WSPrice.FilterMode Then WSPrice.ShowAllData ' البحث عن عمود نوع التعامل Set Clé = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, _ LookAt:=xlWhole) If Not Clé Is Nothing Then ' افراغ البيانات السابقة For a = 8 To 32 Union(dest.Range("A" & a), dest.Range("C" & a), dest.Range("G" & a & ":H" & a)).ClearContents Next a '******** ' جلب البيانات من القائمة************* ' بشرط كود الصنف عمود 'B' For Each r In dest.Range("B8", dest.Cells(Rows.Count, 2).End(xlUp)) 'D' البحث في قائمة الاسعار عمود Set Rng = WSPrice.Range("D:D").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then '7(G)' وضع السعر في عمود dest.Cells(r.Row, 7).Value = WSPrice.Cells(Rng.Row, Clé.Column).Value ' تحديد عود السعر بشرط الخلية 'E4 For Key = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row 'items'جلب اسم الصنف من ورقة Set Col = WSitems.Cells.Find(What:=dest.Range("B" & Key), LookAt:=xlPart) If Not Col Is Nothing And Col <> "" Then dest.Range("C" & Key) = Col.Offset(0, 1).Value Next Key End If Next ' تسلسل عمود 'A' For Each s In Title If s.Value <> "" Then J = J + 1: s.Offset(0, -1).Value = Format(J, "0") Next fRng = dest.Range("B" & dest.Rows.Count).End(xlUp).Row 'القيمة F*G With dest.Range("H8:H" & fRng) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With ' نسخ اسم قائمة السعر المستخدمة dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name Else MsgBox "نوع التعامل غير موجود" & _ vbCrLf & "", vbExclamation, XPric End If .EnableEvents = True .ScreenUpdating = True End With End Sub وكما سبق الذكر سابقا عند نسخك للكود على ملفك الاصلي تأكد من تطابق بيانات الخلية E4 مع رؤؤوس الأعمدة في أوراق قوائم الأسعار اليك الملف للتجربة price list officena V4.xlsm

ربما غير واضح ويلزمه بعض التركيز 🤔😁 تفضل اخي جرب واي استفسار او اظافة لا تتردد في دكرها Sub GetPrice() Dim Lastrow&, Dest_Last&, Cpt&, DataRow&, WSDestRow&, i& Dim WSPrice As Worksheet, WSDest As Worksheet, WS As Worksheet Dim Clé As Object, dictKey As String, Price_list As String Dim srcRng As Range, KeyRng As Range, Dest_Rng As Range Dim Col As Variant, f As Variant, Réf As Variant Dim ShtDate As Date, MaxDate As Date With Application .EnableEvents = False .ScreenUpdating = False Set WSDest = Worksheets("itemout"): Price_list = WSDest.[B4].Value If Price_list = vbNullString Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub If Len(Price_list) > 0 Then If IsDate(WSDest.Range("B4").Value) Then For Each WS In Worksheets If IsDate(WS.Name) Then ShtDate = CDate(WS.Name) If ShtDate <= Price_list And ShtDate > MaxDate Then MaxDate = ShtDate End If Next WS If MaxDate = 0 Then MsgBox "قائمة الأسعار " & Price_list & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else On Error Resume Next Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) With WSPrice DataRow = 5 Lastrow = .Range("D" & .Rows.Count).End(xlUp).Row Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(Lastrow, "J")) Col = srcRng.Value2 End With With WSDest WSDestRow = 8 Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row Set KeyRng = .Range(.Cells(WSDestRow, "B"), .Cells(Dest_Last, "F")) f = KeyRng.Value2: Set Dest_Rng = .Cells(WSDestRow, "G") WSDest.[G8:G32] = Empty ReDim Réf(1 To UBound(f, 1), 1 To 1) End With Set Clé = CreateObject("Scripting.dictionary") For i = 1 To UBound(Col) dictKey = Col(i, 1) If Not Clé.exists(dictKey) And (dictKey) <> "" Then Clé(dictKey) = i End If Next i For i = 1 To UBound(f) dictKey = f(i, 1) If Clé.exists(dictKey) Then Cpt = Clé(dictKey) Réf(i, 1) = Col(Cpt, 7) End If Next i Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf End If End If End If .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم جلب الأسعار من قائمة" & " " & WSPrice.Name & " " & "بنجاج", _ vbInformation, "التحقق من قوائم الأسعار" End Sub price list officena V2.xlsm

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