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

أبسط الحلول هي أن تكون الملفات كلها فى مجلد واحد و بالتالي لا تتأثر بنقل المجلد بالكامل و اذا كان هناك ملف به معادلات مرتبط بملفات أخري بها مصدر للبيانات فى مجلد معين و تغير مكان هذا المجلد يمكنك استبدال المسار باستخدام خاصية الاستبدال CTR+H مثلا اذا كان المجلد الذي به البيانات سابقا فى المسار C:\Users\mtara\Desktop\@risk\4\ ز كان اسم الملف على سبيل المثال b.xlsx و كانت احدى المعادلات فى الملف الذي به المعادلات على سبيل المثال C:\Users\mtara\Desktop\@risk\4\[b.xlsx]bb'!$A$1 و تم نقل الملف b.xlsx الذي يمثل مصدر البيانات الي المسار C:\Users\mtara\Desktop\1\ فتصبح المعادلة ='C:\Users\mtara\Desktop\1\[b.xlsx]bb'!$A$1 فيتم تنفيذ الاستبدال كالتالي مرة واحدة فى ورقة العمل بالملف الذي به المعادلات فتتحدث كل المعادلات لتقرأ من الملفات التي هي فى المسار الجديد : و تتغير كل الملفات

وعليكم السلام-نبهنا كثير جداً على هذا الأمر لا وجود لأى مشاركة بدون ملف !!!فلا تنتظر المساعدة من أحد بدون رفع ملف مدعوم بشرح كافى عن المطلوب مع وضع شكل النتائج المرجوة فلا يمكن العمل على التخمين وتجنباً لإهدار وقت كل من يطلع على مشاركتك دون أدنى جدوى أو أهمية مثلى أنا الأن !!!!!

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي الكريم Private Sub CommandButton1_Click() Dim filePath As String Dim Ws As Worksheet Application.ScreenUpdating = False filePath = Application.ActiveWorkbook.Path Set Ws = Sheets("بيانات") With Ws .Copy Application.DisplayAlerts = False Application.CutCopyMode = False Dim shape As Excel.shape For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & .Name & "" & "" & ".xlsx", FileFormat:=51 Application.ActiveWorkbook.Close False End With MsgBox "تم نسخ الملف بنجاح" Application.ScreenUpdating = True End Sub wor_MH.xlsm

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

هو في العادة يكون من الجدول كما اشار الاستاذ مؤمن مع ذلك ممكن لو اردنا عمل خانة اختيار في الاستعلام بدون التعديل على الجدول الرئيسي ممكن نعمل جدول مساند يحتوي على حقلين فقط المعرف ويكون مفتاح اساس وخانة الاختيار ثم نعمل العلاقة بينهم في الاستعلام انظر للصور تحياتي

السلام عليكم ورحمة الله تعالى وبركاته بالنسبة للكود يمكنك جعله بهده الطريقة اخي الكريم وسبب تاخيري عن الرد على طلبك هو انني كنت انتظر جوابك بخصوص كود المنتج لاكن للاسف جوابك غير مفهوم (كود المنتج يكتب آليا ) تتضمن عدة امور Private Sub CommandButton10_Click() If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("b:b"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If With ActiveSheet If .FilterMode Then .ShowAllData lr = .Cells(Rows.Count, 1).End(3).Row + 1 Cells(lr, 1).Resize(, 4) = Array(lr - 1, txt_product, txt_price_sale, txt_price_pru) End With Me.txt_product.Value = "" Me.txt_price_sale.Value = "" Me.txt_price_pru.Value = "" MsgBox "Done", vbtnformation End Sub اما الزيادة التي سبق ان وعدتك بها في المشاركة السابقة هي عبارة عن ملفك يتضمن جميع الاظافات التي من الممكن ان تحتاجها . ترحيل _ تعديل _ حدف _ بحث بكود المنتج Private Sub CommandButton9_Click() '''''''''ترحيل البيانات''''''''' ''الشرط الاول'' If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If ''الشرط الثاني'' If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If ''الشرط الثالث'' If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If ''التحقق من وجود اسم المنتج مسبقا '' Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("B:B"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If ''''''''''' النطاق المرحل اليه'''''''''''' Dim lr As Long lr = Sheets("product_master").Range("B" & Rows.Count).End(xlUp).Row With sh .Cells(lr + 1, "b").Value = Me.txt_product.Value .Cells(lr + 1, "c").Value = Me.txt_price_pru.Value .Cells(lr + 1, "d").Value = Me.txt_price_sale.Value End With ''''''''افراغ textbox''''''' Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" ''''''''(A)ترقيم تلقائي لعمود '''''' ''مع امكانية حدف الصفوف '' Worksheets("product_master").Activate Application.EnableEvents = False With Range("a2:a" & Cells.Find("*", , , , xlByRows, xlPrevious).Row) .Formula = "=Row() - 1" .Value = .Value End With Application.EnableEvents = True MsgBox "تم الترحيل بنجاح", vbtnformation '' UserForm_تحديث '' Unload Me frm_product_master.Show End Sub '''''''''' البحث بكود المنتج'''''''''''' Private Sub CommandButton10_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then txt_product = Sheets("product_master").Cells(y, 2).Value txt_price_pru = Sheets("product_master").Cells(y, 3).Value txt_price_sale = Sheets("product_master").Cells(y, 4).Value End If Next y End Sub ''''''''''''''''تعديل البيانات'''''''''''''''' Private Sub CommandButton12_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Sheets("product_master").Cells(y, 2).Value = txt_product Sheets("product_master").Cells(y, 3).Value = txt_price_pru Sheets("product_master").Cells(y, 4).Value = txt_price_sale End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم التعديل بنجاح", vbInformation End Sub ''''''''''''''''حدف صف معين'''''''''''''''' Private Sub CommandButton13_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Rows(y).Delete End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم حدف البيانات بنجاح", vbInformation Call MH Unload Me frm_product_master.Show End Sub ''''''''''''''''UserForm _ تحديث واجهة '''''''''''''''' Sub Refresh_data() Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") Dim lr As Long lr = Sheets("product_master").Range("a" & Rows.Count).End(xlUp).Row If lr = 1 Then lr = 2 With Me.ListBox .ColumnCount = 4 .ColumnHeads = True .RowSource = "product_master!A2:d" & lr End With End Sub Private Sub CommandButton14_Click() If MsgBox("هل تريد الخروج من البرنامج", vbQuestion + vbYesNo, "Confirmation") = vbYes Then Unload Me End If End Sub Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean) txtSearch.Text = ListBox.Column(0) If txtSearch.Text = Me.ListBox.Column(0) Then Me.txt_product = Me.ListBox.Column(1) Me.txt_price_pru = Me.ListBox.Column(2) Me.txt_price_sale = Me.ListBox.Column(3) End If End Sub المحل_MH.xlsm

أنا تظهر معي هكذا ( أوفيس 365 ) : 🙂

@Mohamed Hicham لماذا تستخدم الحلقة التكرارية وخاصية اختيار الملفات ؟ من شانه ان يجعل الكود بطيء ، دائما نلجا الى الفلترة او الفلترة المتقدمة لسرعتها خصوصا ان بيانات الاخ tahar صغيرة اما اذا كانت البيانات ضخمة عندها نستخدم الحلقة التكرارية مع المصفوفات لتسريع الكود. مجرد ملاحظة فقط ..تحياتي .

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي الكريم يمكنك وضع الكود التالي وفلترة العمود بعشرة اعداد دفعة واحدة قابلة للزيادة . Sub Filter_() Dim Criteria_MH(100) As String Dim i As Integer Application.ScreenUpdating = False Sheets("ارقام الفلترة").Activate Range("A2:A12").Select For i = 0 To Selection.Count Criteria_MH(i) = Selection(i) Next Sheets("الجدول").Range("A3:A100").AutoFilter Field:=1, Criteria1:=Criteria_MH, Operator:=xlFilterValues Sheets("الجدول").Activate Application.ScreenUpdating = True End Sub tahar-MH.xlsm

Sub Test() Dim ws As Worksheet, sh As Worksheet, r As Range, d As Object, i As Long Application.ScreenUpdating = False Set ws = Sheets(1): Set sh = Sheets(2) Set d = CreateObject("Scripting.Dictionary") With ws Set r = .Range("B4:BF" & .Cells(Rows.Count, 3).End(xlUp).Row) For Each r In Intersect(r, r.Offset(1, 2)) If r.Value <> "" Then i = r.Row d(.Cells(i, 2) & .Cells(i, 3) & r) = Array(.Cells(i, 2), .Cells(i, 3), r) End If Next r End With With sh .Range("C3:BE15").ClearContents .Range("BK1").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items)) .Range("BN1:BN" & d.Count).Formula = "=BL1&BM1" With .Range("C3:BE15") .Formula = "=IFERROR(INDEX($BK:$BK,MATCH($B3&C$2,$BN:$BN,0)),"""")" .Value = .Value End With .Columns("BK:BN").ClearContents End With Application.ScreenUpdating = True End Sub

بورك فيك تمت تجربة الملف يعمل 100 % الان لديا ملفان يعملان بنفس الطريقة ملف الاخ بن علية وملفك انت اخ سليم لكن بدوال مختلفة اكيد هو سحر الاكسيل يا خبراء ادامكم الله عونا لنا وزادكم من علمه

إذا كان المطلوب كما في الصورة اتبع الخطوات من قائمة تنسيق اختر محاذاة واختر منها التفاف النص

جرب هذه الملف في النطاق A2:k11 (يمكن تعديل هذا النطاق من داخل الكود) الكود مرفق Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim my_rg As Range Dim col%, r%, x%, t% Application.EnableEvents = False Set my_rg = Range("a2:k11") If Intersect(Target, my_rg) Is Nothing Then GoTo 1 If Target.Rows.Count <> 1 Then GoTo 1 r = Target.Row: col = Target.Column t = Cells(r, 1).End(xlToRight).Column: If t > 11 Then t = 1 x = Application.CountA(Range(Cells(r, 1), Cells(r, col))) If x <> col Then MsgBox ("Out Of range") Target.Value = vbNullString If t = 1 Then Cells(r, 1).Select Else Cells(r, t + 1).Select End If End If 1: Application.EnableEvents = True End Sub الملف No_cells_to_skeep.rar