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

حقا !!!  تريدني  ان  اقوم  بتنسيق  ملفك  وانت  من  تريد  المساعدة  . هذا  اهدار  لوقتي  ولست مستعد   لمراجعة  الخلايا  المدمجة .
 لن  ادخل  في  هكذا  مواضيع  في  المستقبل .
على اي  حال  لضيق  وقتي  هذه  محاولة  بخصوص  المطلوب  الاول  .  ولم  افهم  شيء  بخصوص  المطلوب  الثاني , وما  الهدف  منه ؟
كما  تلاحظ من  خلال  الكود  قمت  بتخصيص  الايام  بالعربي  لانه  تظهر  بالانجليزي  ( عندما  تتغير  القيم  في  خلايا  العمود C   سوف  يدرج  تاريخ  اليوم  ويوم من الاسبوع)
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim TodayValue As String If Target.CountLarge > 1 Then Exit Sub If Not Intersect(Target, Range("C:C")) Is Nothing Then TodayValue = Choose(Weekday(Date), "الاحد", "الاثنين", "الثلاثاء", "الاربعاء", "الخميس", "الجمعة", "السبت") Target.Offset(0, -1) = Date Target.Offset(0, -2) = TodayValue End If End Sub تحياتي .

اخي  الكريم  لماذا   لا تبحث  في  المنتدى اذا  لم  تجد  تفاعل  من  الاعضاء  حول  موضوعك 
لا تعتمد  كثيرا   ان  يقوم  شخص  بانشاء  لك  كود  من  الصفر  (ابحث  في  المنتدى  وقم  بتطويع  احد  الاكواد بناء  على  احتياجاتك لان  المنتدى  تعليمي)
جرب  هذه  المحاولة  بالفلترة  ( ملاحظة  : اذا  كانت  البيانات  ضخمة  جدا  عندها  الفلترة  تكون  عديمة  الجدوى)
Sub FilterData() Dim startDate As Long, endDate As Long startDate = sheet2.Range("C2").Value endDate = sheet2.Range("C3").Value sheet2.Range("A6").CurrentRegion.ClearContents With sheet1.UsedRange .AutoFilter 1, ">=" & startDate, xlAnd, "<= " & endDate .SpecialCells(xlCellTypeVisible).Copy sheet2.[A6] .AutoFilter End With End Sub Search between two dates ‬.xlsm

اخي  الكريم  كيف  تطبق  الكود على  بيانات  مختلفة  في  الموقع  .
وجب  عليك  تنزيل  الملف  الاصلي   اذا  كنت  غير  ملم  ببعض  الاشياء في   VBA Excel 
لقد  قمت  ببعض  التعديلات  لا ادري  اذاكنت  تريد  التطبيق  على  العمودين   E,F   وهذا  ما  فعلته 
في  المرة  القادمة وضح  اين  تريد  تطبيق  النتائج  ليس  مجرد  تنزيل  ملفين  لا احد  يقوم بتتبع  الكود  سطر  بسطر  حتى  يعلم  ما يفعله  الكود .
دائما  ضع  النتائج  قبل  وبعد حتى يستطيع  الاعضاء من مساعدتك.
تحياتي
تكلفة.xlsm

اخي  الكريم  هذا  موضوع  مختلف    لا يحتاج  الى  شخص  لديه  خبرة  كبيرة  حتى  يصيغ  السؤال  بشكل  جيد  .
عندما  نرى  اليوزرفورم  لا يوجد  زر  هذا  يعني  تريد  اظهار  البيانات في  اليوزرفورم  وليس  العكس  كان  عليك  اختصار  الامر  بقول  ترحيل  البيانات من  اليوزرفورم  الى  الشيت .  الى  هذا  الحد  صعب  قول ذلك ؟؟؟؟؟
هذه مضيعة للوقت  في  المرة  الاولى  طلبت  نفس  الخلية B4  لكلتا  الورقتين  والان  تغير  الخلية . هل  علينا  ان  نقوم  بالتخمين ؟؟
قم بانشاء  زر  تحكم   وضع هذا  الكود  وامسح  الكود  السابق . هذا  الكود لورقة واحدة كما طلبت .
Private Sub CommandButton1_Click() Dim sh1 As Worksheet Set sh1 = Sheets("sheet1") sh1.Range("B4").Value = TextBox1.Value sh1.Range("D5").Value = TextBox2.Value End Sub  
  

قم  بتطويع  الكود  بناء  على  اختيار  المدى  كما  في  التعليق  ونسخه  في موديول  الورقة 
Private Sub Worksheet_Change(ByVal Target As Range) 'غير الاعمدة المراد تنفيدها مع مراعاة تكون الاعمدة متعاقبة If Not Intersect(Range("D:M"), Target) Is Nothing Then Dim myrange As Range With Target If Len(.Value) > 0 Then Set myrange = Columns(.Column) Application.EnableEvents = False If WorksheetFunction.CountIf(myrange, .Value) > 1 Then MsgBox .Value & " عذرا هذا الوقت مكرر.", vbExclamation .ClearContents End If Application.EnableEvents = True End If End With End If End Sub  

Private Sub TxtSearch_Change() Dim x As Long Me.TxtSearch.Text = StrConv(Me.TxtSearch.Text, vbProperCase) Me.ListBox1.Clear For x = 4 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A")) a = Len(Me.TxtSearch.Text) If Left(Sheet1.Cells(x, 1).Value, a) = Left(Me.TxtSearch.Text, a) Then Me.ListBox1.AddItem Sheet1.Cells(x, 1).Value Me.ListBox1.List(ListBox1.ListCount - 1, 1) = Sheet1.Cells(x, 2).Value Me.ListBox1.List(ListBox1.ListCount - 1, 2) = Sheet1.Cells(x, 3).Value Me.ListBox1.List(ListBox1.ListCount - 1, 3) = Sheet1.Cells(x, 4).Value End If Next x End Sub  
 
 
ADVANCED SEARSH.xlsm

@Mohamed Hicham  المطلوب  باليوزرفورم وليس  داخل  الورقة  كما فعلتها 
@احمد مبارك  كيف  نعرف   اذا  كان  باليوزرفورم او  داخل  الورقة  لم  تشرح ذلك  ولم  تضع  زر  لليوزرفورم حتى  يعلم  الاعضاء 
مجرد  صدفة عند  دخول محرر الاكواد  وجدت  اليوزرفورم 
جرب  هذا  الكود
Private Sub UserForm_Initialize() Dim i As Long For i = 2 To Sheets.Count Me.ComboBox1.AddItem Sheets(i).Name Next i End Sub اخفاء ورقة عمل في الكمبوبوكس.xlsm

احدف  بياناتك  قي  الشيت  الثاني  ابتداء  من BI1
Sub test() Dim r As Range Sheets("sheet2").UsedRange.Clear With Sheets("sheet1") Set r = .[t1:t2] With .Range("t3", .Range("t" & Rows.Count).End(xlUp)).Resize(, 8) r(2).Formula = "=countblank(" & .Rows(2).Range("c1").Resize(, 6).Address(0, 0) & ")<6" .AdvancedFilter 2, r, Sheets("sheet2").Cells(61) End With r.Clear End With End Sub  

مجرد  محاولة 
غير  هذه 
For Each xFile In xFolder.Files الى 
For Each xFile In xFolder.subfolders  

انسخ  هذا  في  موديول  اليوزرفورم ( اكتب   الرقم في  التيكست بوكس فعل  التشيك بوكس)
Private Sub CheckBox1_Click() If CheckBox1.Value = True Then TextBox1.Value = Val(TextBox1.Value) * -1 ElseIf CheckBox1.Value = False Then TextBox1.Value = Val(TextBox1.Value) * -1 End If End Sub  

اخي  الكريم 
هل  يتعبك  ان  تصف  لنا  ما  هو  الخطا  الذي  يظهر  لك .   كيف  نعرف  ؟🤔
,,Application.ScreenUpdating = False احدف  الفاصلتين قبل السطر
 

بعد 5  ايام  يتم  الرد  
كلمة السر  myPass
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Sheet1.Unprotect Password:="myPass" With Target .Cells.Locked = True On Error Resume Next .Cells.SpecialCells(xlCellTypeBlanks).Locked = False On Error GoTo 0 End With Sheet1.Protect Password:="myPass" End Sub  
1مثال.xlsm

على حسب  ما  فهمت   هذا  ما  تحتاجه 
Sub PRINT_OUT() Range("a1:i29").PrintOut Copies:=2 End Sub  

@فوزى فوزى  لم  تجيني  على  استفساري  
لا  اجد  اي  مبرر  لهذه  الطريقة  انت  تصعب  الامور  على  نفسك  وعلينا .
مع  هذا  هذه  محاولة  اذا  لم  يكن  ما  تريده  عليك  انتظار  شخص  اخر.
index.xlsm

ماكرو لتسمية الاوراق
Option Explicit Sub renamesheets() Dim sheetsold() Dim sheetsnew() Dim lngSht As Long Dim ws As Worksheet 'الاسماء الجديدة sheetsnew = Array("selling1", "selling2") 'الاسماء القديمة sheetsold = Array("SH1", "SH3") On Error Resume Next For lngSht = LBound(sheetsold) To UBound(sheetsold) Set ws = Nothing Set ws = Sheets(sheetsold(lngSht)) If Not ws Is Nothing Then ws.Name = sheetsnew(lngSht) Next lngSht End sub  

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

اعتقد  هذا  سيفي  بالغرض 
Sub DeleteRows() With Columns("B:G") .SpecialCells(xlBlanks).Delete Shift:=xlUp .Rows(5).Copy .SpecialCells(xlBlanks).PasteSpecial xlPasteFormats End With Application.CutCopyMode = False End Sub  

في  هذا السطر 
If cll < 15 & cll > 0 Then  يوجد  خطا  استبدل &   ب  and   او  or
مثل  هذا
If cll < 15 and cll > 0 Then  

الرجاء  ضع  الكود  في <> كما موجود في  اعدادات الكتابة والتنسيق  لديك 
غير مجرب .  مجرد  محاولة 
كما ترى انشا  مجلد  في  اي  محرك تريده  ثم قم  بنسخ امتداده وضعه في  الكود 
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  

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

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

حاولت  فهم  لماذ  لم  تطبق  هذه  الفكرة  لم  اجد  لها   حل  حتى الان 
اقتراحي  حدف   العمود  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

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

جرب  هذا  الكود 
sub delete_externallinks() With ActiveWorkbook For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks) .BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks Next End With end sub  

جرب هذا  الماكرو 
لا تنسى  بانشاء  مجلد  backup   في  درايف  c
Sub savefile() Dim Path As String Dim Filename As String Path = "C:\backup\" Filename = Range("B3") ThisWorkbook.Sheets.Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=Path & Filename & ".xlsx", FileFormat:=51 Application.DisplayAlerts = True ActiveWorkbook.Close True End Sub