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

انت  لست  جديد على  هذا  المنتدى  لذلك  يجدر بك ان تسال سؤال واحد 

جرب  هذا  الشي بخصوص الفرز  

كليك يمين على ورقة  العمل ثم اظهار التعليمات البرمجية ثم لصق 

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

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

انتظر المساعدة من الاخرين

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

لا يوجد  مشكلة   الكود  يعمل   . اعتقد   المشكلة   عدم  تتطابق المسافات بين  الاسماء  في  كلا  الورقتين لتجنب ذلك    

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

تحياتي

اقتباس

لايتم نسخ الرقم الموجود امام تلك الاسماء فى شيت رقم 1

حسب  ملفك يتم  نسخ الى شيت 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

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

يمكنك تغيير صيغة التاريخ كما تشاء