الـعيدروس

السلام عليكم شاهد المرفق استدعاء_البيانات_111.rar

السلام عليكم الافضل ارفاق مثال وحبذا تغير اسمك بالعربي تحياتي

الكود هو Set sa = Sheets("1") Set sh = Sheets("2") sh.Cells(2, 2) = sa.Cells(2, 2) sh.Cells(2, 3) = sa.Cells(2, 3) sh.Cells(2, 4) = sa.Cells(2, 4) sh.Cells(2, 5) = sa.Cells(2, 5) sh.Activate لم تغير شيء فيه كما هو الصح كالتالي Sub dd() Set Sa = Sheets("1") Set sh = Sheets("2") With Sa .Cells(2, 2).Copy sh.Cells(2, 2) .Cells(2, 3).Copy sh.Cells(2, 3) .Cells(2, 4).Copy sh.Cells(2, 4) .Cells(2, 5).Copy sh.Cells(2, 5) End With sh.Activate End Sub او هكذا كإختصار الاسطر Sub dd() Set Sa = Sheets("1") Set sh = Sheets("2") With Sa Union(.Cells(2, 2), .Cells(2, 3), .Cells(2, 4), .Cells(2, 5)).Copy sh.Cells(2, 2) End With sh.Activate End Sub تحياتي

السلام عليكم كالتالي sa.Cells(zz, 5).Copy Sh.Cells(LR1, 5)

ارفق مثال وبه اوراق للاشهر المعنيه كما في ملفك الاصلي اي مسميات الاوراق وماهي شروط الترحيل وضحها في المرفق شهرين وقلت وعدد 15 صفحه الشهرين تقصد لكل شهر ورقه وفي كل شهر 15 جدول ؟

جرب هذا التعديل Sub Ali_C() Dim Sw As Worksheet, Sh As Worksheet Dim Lr, LrR, Rw As Long Dim Rn As Range, Rng As Range, R As Range Set Sw = Sheets("1"): Set Sh = Sheets("data") Lr = Sw.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row '----------- Ali_Ap False '----------- With Sw For Rw = 5 To Lr Step 21 I = I + 1 ''----------------------------------------------------------------------------------------- Set Rn = .Cells(Rw + 4, "C").End(xlDown): Rr = Split(Rn.Address, "$")(2) LrR = Sh.Cells(Sh.Rows.Count, 5).End(xlUp).Offset(IIf(I = 1, 1, 2)).Row .Range("M" & Rw).Copy: Sh.Range("B" & LrR).PasteSpecial xlPasteValues .Range("B" & Rw + 1).Copy: Sh.Range("C" & LrR).PasteSpecial xlPasteValues .Range("D" & Rw).Copy: Sh.Range("D" & LrR).PasteSpecial xlPasteValues .Range(.Cells(Rw + 4, "C"), "C" & Rr).Copy: Sh.Range("E" & LrR).PasteSpecial xlPasteValues ''----------------------------------------------------------------------------------------- .Range(.Cells(Rw + 4, "E"), "E" & Rr).Copy: Sh.Range("F" & LrR).PasteSpecial xlPasteValues .Range(.Cells(Rw + 4, "I"), "I" & Rr).Copy: Sh.Range("G" & LrR).PasteSpecial xlPasteValues .Range(.Cells(Rw + 4, "AD"), "AD" & Rr).Copy: Sh.Range("H" & LrR).PasteSpecial xlPasteValues .Range(.Cells(Rw + 4, "AE"), "AE" & Rr).Copy: Sh.Range("I" & LrR).PasteSpecial xlPasteValues .Range(.Cells(Rw + 4, "AF"), "AF" & Rr).Copy: Sh.Range("J" & LrR).PasteSpecial xlPasteValues ''----------------------------------------------------------------------------------------- Next End With '----------- Ali_Ap True '----------- Application.CutCopyMode = False Set Sw = Nothing: Set Sh = Nothing: Set Rn = Nothing End Sub Public Function Ali_Ap(Bn As Boolean) With Application .Calculation = IIf(Bn, -4105, -4135) .ScreenUpdating = Bn End With End Function

السلام عليكم استخدام حلقة لعمل مسلسل للثواني مرهق للذاكره والتهنيج مؤقت انقر مرتين في اي خليه

هل عدد صفوف الجدول ثابته ؟ وهل الصفوف الفارغه بين كل جدول ثابته ؟ وكم الحد الاعلى للجداول

السلام عليكم تفضل المرفق انقر على زر "نقل المعدلات" وشاهد النتائج في ورقة "تحليل النتائج " مطلوبي_111.rar

السلام عليكم ارفق مثال لم نفهم السؤال

السلام عليكم حسب فهمي للمطلوب جرب الكود التالي Sub Ali() Dim Sw As Worksheet, Sh As Worksheet Dim Lr As Long, Rw As Long Dim R As Range Set Sw = Sheets("1"): Set Sh = Sheets("data") With Sw Lr = Split(Sh.UsedRange.Address, "$")(4) Sh.Cells(Lr, 2) = .[M5] Sh.Cells(Lr, 3) = .[D6] Sh.Cells(Lr, 4) = .[D5] Set R = [C9].End(xlDown) Rw = Split(R.Address, "$")(2) Union(.Range(.[C9], "C" & Rw), .Range(.[E9], "E" & Rw), .Range(.[I9], "I" & Rw) _ , .Range(.[AD9], "AD" & Rw), .Range(.[AE9], "AE" & Rw), .Range(.[AF9], "AF" & Rw)).Copy Sh.Cells(Lr, 5).PasteSpecial xlPasteValues Application.CutCopyMode = False End With Set Sw = Nothing: Set Sh = Nothing: Set R = Nothing End Sub

السلام عليكم حط الكود التالي في حدث Thisworkbook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Column = 9 And Target.Row > 1 Then Ali Target End Sub والكود التالي في مودويل Public Sub Ali(ByVal Tr As Range) Dim A As String Dim R As Range Dim Sht As Worksheet With Tr On Error GoTo Nx Set Sht = Sheets(.Text) 2 With ActiveSheet.Range("A" & .Row & ":I" & .Row) .Copy With Sht .Cells(.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row, 1).PasteSpecial xlPasteValues End With .ClearContents End With Application.CutCopyMode = False End With Set Sht = Nothing: Set R = Nothing Exit Sub Nx: Set Sht = Sheets("Main") GoTo 2 End Sub

السلام عليكم اخي الكريم اعد رفع الملف اضغط ملف الاكسل ثم ارفقه تحياتي

بالامكان استخدام الكود التالي في اي حدث للشيت Sub Refresh() ThisWorkbook.RefreshAll End Sub اضغط الزرين التاليه مع بعض "Ctrl+F"

السلام عليكم اخي الكريم ابداء بإنشاء ملف اكسل وضيف عليه تصورك الذي تريده وان صعب عليك نقاط معينه لن يبخل احد بالمساعده وللتذكير ارفاق ملف للعمل عليه وبه بداية المشروع الذي تريده يشجع كل من لديه معلومه ان يشارك في موضوعك تقبل تحياتي

السلام عليكم اخي الكريم محسن محمد بالامكان عمل البرنامج ان لديك افكار للاليه التي تريدها كي تخدمك في عملك بدون مقابل يحتاج منك صبر وللعلم المنتدى هنا للمعرفه وتبادل الخبرات تحياتي

السلام عليكم السموحه على التأخير وذلك لانشغالي تفضل المرفق البحث بمعيارين_111.rar

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

السلام عليكم تفضل Sub TransferDataToClosedWB() On Error Resume Next Dim WB As Workbook Dim LR_A As Long, LR_B As Long, LR_B2 As Long Dim Answer As Long LR_A = IIf(Cells(Rows.Count, 2).End(xlUp).Row = 1, 1, Cells(Rows.Count, 2).End(xlUp).Row) Application.ScreenUpdating = False ThisWorkbook.Sheets("التسجيل").Range("B9:L" & LR_A).Copy ' Set WB = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "البيانات.xlsm") Num_R = ThisWorkbook.Sheets("التسجيل").Cells(Rows.Count, 2).End(xlUp).Row - 9 With Sheets("البيانات") LR_B = IIf(.Cells(.Rows.Count, 1).End(xlUp).Row = 1, 2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1) .Range("A" & LR_B).PasteSpecial xlPasteValues .Range(.Cells(LR_B, "K"), .Cells(LR_B + Num_R, "K")).Value = Sheets("التسجيل").Range("F7").Value .Range(.Cells(LR_B, "L"), .Cells(LR_B + Num_R, "L")).Value = Sheets("التسجيل").Range("I7").Value ' .Range(.Cells(LR_B, "n"), .Cells(LR_B + Num_R, "n")).Value = ThisWorkbook.Sheets("التسجيل").Range("i7").Value End With On Error GoTo 0 ' WB.Close SaveChanges:=True Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

السلام عليكم والدالة وين تريدها في اي عمود لتتضح الصورة لمن اراد المشاركة اخي الكريم قاسم

الفورم غير موجود في مرفقك الاخير ؟ هذا الكود وبه شرح الاسطر المعنيه Private Sub CommandButton2_Click() Dim Sh As Worksheet Dim Sht As Worksheet Dim A As Variant ''width للاشارة لورقة Sh تعين متغير Set Sh = Sheets("width") ''result للاشارة لورقة Sht تعين متغير Set Sht = Sheets("result") ''Samole و Width لادرااج الشروط المراد البحث عنها A تخصيص متغير A = Array("Width", "Samole") '' Ali_F غير فارغ استدعي الدالة المعرفة TextBox1 If Me.TextBox1 <> Empty Then Ali_F TextBox1, A(0), Sh If Me.TextBox2 <> Empty Then Ali_F TextBox2, A(1), Sht ''========================================================== '' شرح الدالة المعرفه ''---- 'Ali_F(Tx, id, Tb As Worksheet) ''---- ''Tx القيمة التي تود حفظها في العمود المقابل لنتيجة البحث ''TextBox1 طبعاً القيمة هيا ماتكتبه في ''---- ''id قيمة البحث ''"Width" A(0) A وهو القيمة الاولى في متغير ''---- ''Tb الورقة المراد البحث فيها '' Sh = "width" TextBox1 للـ '' Sht = "result" TextBox2 للـ ''========================================================== End Sub Public Function Ali_F(Tx, id, Tb As Worksheet) Dim Sht As Worksheet Dim Rng As Range Set Sht = Tb With Sht Set Rng = .Cells.Find(What:=id) '' If Not Rng Is Nothing Then Rng.Offset(, 1).Value = Tx End With End Function

اي كمبوكس تقصد اخي وائل ؟

اخي عبدالعزيز البسكري هيا شرح فيديو لطريقتك بارك الله فيك تقبل تحياتي وشكري

مااضن تأكد من البيانات

السلام عليكم تفضل ترحيل أعمدة متفرقة_يحتاج تعديل_11.rar