محمد عدنان قام بنشر مايو 20 مشاركة قام بنشر مايو 20 (معدل) السلام عليكم و رحمة الله و بركاته ارجو المساعدة بماكرو يقوم من الصفحة form2 من الخلية g5 اختيار اسم الغرقة يقوم باستدعاء محتويات الغرفة من الشيت Data جسب الفورم ملاحظة يقوم باستدعاء المحتويات التي الممتلئة فقط * و ماكرو اخر يقوم الاستعلام باسم المادة و اماكن وجود ها بالغرف form3 مرفق الملف بارك الله فيكم و جزاكم الله كل خير DATA.rar تم تعديل مايو 20 بواسطه محمد عدنان رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر مايو 21 مشاركة قام بنشر مايو 21 وعليكم السلام ورحمة الله تعالى وبركاته 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 21 ساعات مضت, محمد عدنان said: و ماكرو اخر يقوم الاستعلام باسم المادة و اماكن وجود ها بالغرف form3 تمت اظافته للملف المرفق بالتوفيق ....... DATA V2.xlsb 1 رابط هذا التعليق شارك More sharing options...
محمد عدنان قام بنشر مايو 21 الكاتب مشاركة قام بنشر مايو 21 (معدل) السلام عليكم اخ @محمد هشام. بارك الله بجهدك الفورم الاول لا يعطي ما هو موجود في الغرفة مثال الغرفة 1 يعطي مادة 1 1 مادة 3 1 في خانة او عمود الرصيد و هكذا لكن الفورم الثاني ليس كما هو مطلوب المطلوب في form3 ان اختار المادة من الخلية g5 بكود يحدد اسماء الغرف المتواجدة و عددها في كل غرفة مرفق مثال كما في الصورة تم تعديل مايو 21 بواسطه محمد عدنان رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر مايو 21 مشاركة قام بنشر مايو 21 (معدل) 19 ساعات مضت, محمد عدنان said: الفورم الاول لا يعطي ما هو موجود في الغرفة مثال الغرفة 1 يعطي مادة 1 1 مادة 3 1 في خانة او عمود الرصيد و هكذا لكن الفورم الثاني ليس كما هو مطلوب المطلوب في form3 ان اختار المادة من الخلية g5 بكود يحدد اسماء الغرف المتواجدة و عددها في كل غرفة مرفق مثال كما في الصورة اخي طلبك غير واضح بالنسبة لي ما هي علاقة الغرفة 1 بالمادة 13 مثلا !!!!!!!!!!!! حتى لو قمت بتجربة الدهاب الى عمود الغرفة 1 وقمت بفلترتها على الخلايا الغير فارغة لن تجد غرفة 13 في عمود (نوع اللوازم و مواصفاتها ) ربما يجب عليك اعادة صيغة طرح طلبك مع مزيدا من التوضيح او ارفاق عينة للنتائج المتوقعة المرجوا جعل كل طلب في موضوع مستقل تم تعديل مايو 21 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر مايو 22 أفضل إجابة مشاركة قام بنشر مايو 22 (معدل) لقد لاحظت انك قمت بفتح موضوع جديد بالطلب الثاني خطوة جيدة لاكن يبدو اننا بحاجة لانهاء الموضوع الاول وغلقه للمررور للطلب الثاني بادن الله بعد معاينة بعض التعاليق التي قمت انت باظافتها على الكود لاحظت انك ترغب بجلب بيانات عمود الغرفة المحددة الى عمود الرصيد ورقة 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 رابط هذا التعليق شارك More sharing options...
محمد عدنان قام بنشر مايو 22 الكاتب مشاركة قام بنشر مايو 22 السلام عليكم اخ @محمد هشام. بعتذر منك لاني ما اقدر ت اوصل الك ما اريد بطريقة مبسطة الكود الكود يعمل بشكل ممتار اما بالنسبة FORM3 يكون الاستعلام بالعكس من الكود الاول اي اختار اسم الماد ة .... و النتيجة موقعها في الغرف بارك الله فيك و اشكرك رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر مايو 23 مشاركة قام بنشر مايو 23 (معدل) تمام اخي بما انك توصلت للنتيجة المتوقعة بخصوص الطلب الاول يفضل غلق الموضوع اما بخصوص طلبك الثاني ساقوم بنشره بادن الله في مكانه الصحيح بعد اظافة ورقة FROM3 تم تعديل مايو 23 بواسطه محمد هشام. 1 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان