عبدالفتاح في بي اكسيل

راجع الملف

انت لست جديد على هذا المنتدى لذلك يجدر بك ان تسال سؤال واحد جرب هذا الشي بخصوص الفرز كليك يمين على ورقة العمل ثم اظهار التعليمات البرمجية ثم لصق Option Explicit Private Sub WorkSheet_Change(ByVal Target As Range) If Target.Column = 2 Then Dim lastrow As Long lastrow = Cells(Rows.Count, 1).End(xlUp).Row Range("a7:h" & lastrow).Sort key1:=Range("b7:b" & lastrow), order1:=xlAscending, Header:=xlNo End If End Sub بالنسبة لكود الطباعة sub hidcol Range("C:C").EntireColumn.Hidden = True ActiveSheet.PrintOut Range("C:C,").EntireColumn.Hidden = False end sub 1طباعة.xlsm

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

هلا اخبرتنا ما الفائدة من حدف مجلد بناء على تاريخ محدد

لماذا لا تضعهم في ورقتين في ملف واحد وتكون المطابقة اسهل ويكون الكود اسرع في هذه الحالة لا تصعب الامور على نفسك

الرجاء ضع الكود في <> كما موجود في اعدادات الكتابة والتنسيق لديك غير مجرب . مجرد محاولة كما ترى انشا مجلد في اي محرك تريده ثم قم بنسخ امتداده وضعه في الكود Private Sub CommandButton3_Click() Const csPath As String = "C:\Test\" If TextBox2.Value = "" Then MsgBox "ادخل اسم الصورة اولا": Exit Sub Var = TextBox2.Text مكان حفظ الصور ' SavePicture Image1.Picture, csPath & Var & ".jpg" MsgBox "تم حفظ الصورة بنجاح مع تحيات مجدى يونس", vbInformation End Sub

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

تم تعديل الكود

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

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

لماذا لم تجيبني على سؤالي هل ظهر لك اي خطأ؟ المشكلة كانت بسيطة وخطا في المدى كان يجب عليك تصحيحها ولماذا لم تضع الماكرو الذي اقترحته عليك بالملف لاحظ في المعادلة غيرت الفاصلة الى , بسبب اصدار الاوفيس عندي اذا لم تعمل معك غيرها الى ; وغير اسم الشيت تم تعديل الكود في المشاركة السابقة حضور و غياب بصمة2021.xlsm

جرب هذا التعديل Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Columns(1)) Is Nothing Then Application.EnableEvents = False Target.Offset(, 1).Resize(, 14).Delete xlShiftUp End If Application.EnableEvents = True End Sub

اذن المشكلة من ملفك كيف لايعمل هل يظهر خطا ؟ جربته على ملف خالي من البيانات تماما وقام بادراج المعادلة

في المرة القادمة ضع كل متطلباتك وليس كل مرة يتم تعديل الكود تحياتي match & copy (1).xlsm

هذا ماكرو بسيط من غير حلقة تكرارية يمكنك التعديل في المدى والاعمدة Sub MyFillDown() With ThisWorkbook.Sheets("Sheet2") .Range("f9,i9,l9,o9,r9").Formula = "=IFERROR(HOUR(D9-$D$3)*60+MINUTE(D9-$D$3);"""")" .Range("f9:f66,i9:i66,o9:o66,r9:r66").FillDown End With End Sub

حاولت فهم لماذ لم تطبق هذه الفكرة لم اجد لها حل حتى الان اقتراحي حدف العمود g وضع هذا الماكرو في حدث الملف عند الضغط على زر الغاء او اغلاق سيتم الخروج من الرسالة Private Sub Workbook_Open() Dim c As Range ' For Each c In Range("F4", Range("F" & Rows.Count).End(3)) If c.value < 0 Then If MsgBox("انتبه ...! هناك اشتراكات انتهت مدة صلاحيتها ", vbOKCancel + vbExclamation + vbDefaultButton2, "تنبيه ! تنبيه ! تنبيه !") = vbCancel Then Exit Sub End If Next End Sub زياد.xlsm

جرب هذا الماكرو Sub match_copy() Dim lRow, x As Long, ws As Worksheet Set ws = Sheets("Sheet1") lRow = ws.Range("B1").End(xlDown).Row For Each cell In Range("B2:B" & lRow) x = 2 Do If cell.Value = Sheets("Sheet2").Cells(x, "A").Value Then Sheets("Sheet2").Cells(x, "H").Value = cell.Offset(, 11) Sheets("Sheet2").Cells(x, "i").Value = cell.Offset(, 10) Sheets("Sheet2").Cells(x, "j").Value = cell.Offset(, 9) End If x = x + 1 Loop Until IsEmpty(Sheets("Sheet2").Cells(x, "A")) Next Sheets("Sheet2").Activate End Sub match & copy.xlsm

ادرج ملف والنتيجة التي تريدها حتى تجد تفاعل اكبر من الاعضاء

اولا اين الملف ثانيا على حسب علمي هذا كود نسخ البيانات من حوالي 55 مربع نص الى ورقة العمل وليس تعديل مثل ما ظاهر لعنوان موضوعك ثالثا عندك متغير r اين تعريفه يفترض يشير الى الصف الذي سيتم البدء بنسخ البيانات منه

هذا الموضوع تم تناوله كثيرا لا اداري اين الاختلاف لقد اطلعت على ملفك بشكل سريع تم اصلاح بعض الاشياء جربه Private Sub CommandButton5_Click() Dim lr As Long Dim b As Worksheet Set b = Worksheets("sheet1") lr = b.Cells(Rows.Count, 1) _ .End(xlUp).Row b.Range("a" & lr).Value = Me.TextBox1.Value b.Range("b" & lr).Value = Me.TextBox2.Value b.Range("c" & lr).Value = Me.TextBox3.Value b.Range("d" & lr).Value = Me.TextBox4.Value b.Range("e" & lr).Value = Me.TextBox5.Value b.Range("f" & lr).Value = Me.TextBox6.Value b.Range("g" & lr).Value = Me.TextBox7.Value b.Range("h" & lr).Value = Me.TextBox8.Value b.Range("i" & lr).Value = Me.TextBox9.Value b.Range("g" & lr).Value = Me.TextBox10.Value TextBox2.Value = "" TextBox3.Value = "" ComboBox1.Value = "" TextBox5.Value = "" TextBox6.Value = "" TextBox7.Value = "" ComboBox2.Value = "" TextBox9.Value = "" TextBox10.Value = "" End Sub

جرب تغيير هذا searchdirection:=xlPrevious الى searchdirection:=xlNext

استخدم التنسيق الشرطي حدد الخلية B1 وانتقل الى التنسيق الشرطي واختار الخيار الاخير وانسخ المعادلة ومن تنسيق حدد لون التعبئة =D1<>""

استخدم التنسيق الشرطي بتلوين المكرر بدلا من ذلك

لا يمكنك ذلك اطلاقا بالليست بوكس .استخدم اداة listview

هذه محاولة على حسب الشرح في موضوعك الاصلي على الرغم من شح المعلومات قم بنسخ رؤوس العناوين اولا قبل تنفيد الكود Sub merge_sheets() Dim MUL As Variant Dim Ws As Worksheet MUL = Array("1", "2","3","4","مني","هناء" ) For Each Ws In Worksheets(MUL) Ws.UsedRange.Offset(1).copy Sheets("مجمع شيتات").Range("A" & Rows.Count).End(xlUp).Offset(1) Application.DisplayAlerts = False Application.DisplayAlerts = True Next Ws End Sub