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

بالنسبة  لهذين  السطرين  يعملان  معي   جرب  وضع  السطر  الاول  في  بداية  كود  الترحيل
sheet1.Unprotect pwd اما السطر  الثاني  في  نهاية كود الترحيل
sheet1.Protect pwd  مع مراعاة اسم  الورقة 

جرب  هذا  الماكرو
Sub extractmonth_name() Dim i As Long For i = 4 To 115 Cells(i, 5).Value = Month(Cells(i, 2).Value) Next i End Sub 5.xlsm

اعتقد   تريد  التخلص   من الخلايا  الفارغة بين  الارقام  على حسب  ما  فهمت  تفضل  هذه  المعادلة 
=IFERROR(INDEX($L$1:$L$32;AGGREGATE(15;6;(ROW($L$1:$L$32)-ROW($L$1)+1)/($L$1:$L$32<>"");ROWS(I$2:I2)));"")  
filter (1).xlsx

في هذه  الحالة جرب هذا  الكود 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Range("J23").MergeArea = Application.WorksheetFunction.Sum(Application.ActiveWindow.RangeSelection) End Sub نموذج استلام اجهزة (1).xlsm

جرب هذا  الكود 
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = 5 And Target.Column = 1 Then If Target.Value = "" Then Sheet1.ShowAllData Else Sheet1.Cells.AutoFilter Field:=5, Criteria1:=Target.Value End If End If End Sub مشروع1.xlsm

اعلميني  بالكودين ماذا يحدث  معك  قد  استفيد منه بالمستقبل   وباقي  الاعضاء 
هذا  تحديث  اخر  على  حسب  بياناتك 
Public Sub SendMails() Dim olApp As Object Dim newEmail As Object Dim sMsg As String Dim rng As Range Dim c As Range On Error Resume Next Set olApp = GetObject(, "Outlook.Application") On Error GoTo 0 If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application") End If With ThisWorkbook.Sheets("Sheet1") Set rng = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With For Each c In rng sMsg = c.Value2 & vbCrLf & _ c.Offset(, 1).Value2 & vbCrLf & _ c.Offset(, 2).Value2 & vbCrLf & _ c.Offset(, 3).Value2 & vbCrLf Set newEmail = olApp.CreateItem(0) With newEmail .To = c.Offset(, 4).Text .CC = "" .BCC = "" .Subject = "Subject" .Body = "Dear customer," & vbCrLf & vbCrLf & sMsg & vbCrLf & "Regards" .Display .Send End With Next c End Sub  

جرب هذا  الماكرو  البسيط 
Sub savepdf() ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\pdf\" & Range("c4").Value End Sub  
حفظ بصيغة pdf تلقائيا.xlsm

اعتقد هذا  قد  ينفع معك ضع هذه الصيفة وليكن C2  
=COUNTIF(A2:B4;"*محمد*")  

اعتقد  هذا يفي بالغرض 
Sub Copy() Dim LastRow As Long LastRow = Sheets("Sheet1").Cells(Rows.Count, "b").End(xlUp).Row Sheets("Sheet1").Range("A" & LastRow - 9 & ":B" & LastRow).Copy Sheets("Sheet2").Range("h11") End Sub  

قم بهذا  التعديل 
Private Sub CommandButton2_Click() Application.Visible = True Dim sh As Worksheet With ThisWorkbook.Worksheets("micro") .Visible = xlSheetVisible .Activate End With For Each sh In ThisWorkbook.Worksheets(Array("RAW", "Date", "MICC", "REPORT", "LABLE")) sh.Visible = xlSheetVeryHidden Next sh UserForm1.Hide End Sub Private Sub CommandButton4_Click() Application.Visible = True Dim sh As Worksheet With ThisWorkbook.Worksheets("raw") .Visible = xlSheetVisible .Activate End With For Each sh In ThisWorkbook.Worksheets(Array("micro", "Date", "MICC", "REPORT", "LABLE")) sh.Visible = xlSheetVeryHidden Next sh UserForm1.Hide End Sub  

اعتقد هذا المطلوب
Private Sub Worksheet_PivotTableChangeSync(ByVal Target As PivotTable) Range("h2") = ActiveWorkbook.SlicerCaches(1).VisibleSlicerItems.Count End Sub count selected item in slicer .xlsm

يمكنك  الاستفادة  من هذا  الملف  على  حسب  ما فهمت  
 
=CHOOSE(MOD(ROW()-1;6)+1;"A";"B";"C";"D";"";"")  
numbering alphabet.xlsx

جرب هذا  الكود  يتم  الفرز بناء  على التاريخ
Private Sub Worksheet_Change(ByVal Target As Range) Dim lastrow As Long lastrow = Cells(Rows.Count, 3).End(xlUp).Row Range("A2:c" & lastrow).Sort key1:=Range("c2:c" & lastrow), _ order1:=xlAscending, Header:=xlNo End Sub  
ترتيب تلفائى1.xlsm

على حسب معطياتك  اعتقد  هذا  المطلوب  بالكود  لا يظهر التاريخ  الا في  حالة سداد قسط  معين  بناء على  تاريخ  اليوم  ولن  يتغير في  الايام  القادمة 
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Row > 6 Then If Target.Column = 5 Or Target.Column = 8 Or Target.Column = 11 Then If Target.Value = "سدد" Then Target.Offset(0, 1) = Date Else Target.Offset(0, 1) = "" End If End If End If End Sub  
حسابات (1).xlsb

هذا  بالكود  البرمجي  لعله يساعدك 
تفضل
Sub osama() Dim data, i As Long, fnd As Range With Range("B27:C" & Cells(Rows.Count, 3).End(xlUp).Row) data = .Value For i = LBound(data, 1) To UBound(data, 1) Set fnd = Range("C3:R21").Find(data(i, 2), , xlValues, xlWhole) If Not fnd Is Nothing Then data(i, 1) = Cells(fnd.Row, 2) Next i .Value = data End With End Sub  
جلب اسماء.xlsm

جرب هذا  الكود  لعله  يفي  بالغرض 
Sub Consolidation() Dim CurrentBook As Workbook Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("sheet1") Dim IndvFiles As FileDialog Dim FileIdx As Long Dim i As Integer, x As Integer Set IndvFiles = Application.FileDialog(msoFileDialogOpen) With IndvFiles .AllowMultiSelect = True .Title = "Multi-select target data files:" .ButtonName = "" .Filters.Clear .Filters.Add ".xlsx files", "*.xlsx" .Show End With Application.DisplayAlerts = False Application.ScreenUpdating = False For FileIdx = 1 To IndvFiles.SelectedItems.Count Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx)) For Each Sheet In CurrentBook.Sheets Dim LRow1 As Long LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row Dim LRow2 As Long LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row Dim ImportRange As Range Set ImportRange = CurrentBook.ActiveSheet.Range("A2:d" & LRow2) ImportRange.Copy WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next CurrentBook.Close False Next FileIdx Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub  

جرب هذا  الماكرو
Sub CopyFiltered1() Dim src As Worksheet Dim tgt As Worksheet Set src = ThisWorkbook.Sheets("data") Set tgt = ThisWorkbook.Sheets("Sheet2") src.AutoFilter.Range.Offset(1, 1).Resize(, 5).Copy tgt.Range("B5") End Sub  
mounir.xlsm

تفضل  اعتقد  هذا  ما  تريده  على  حسب  ما فهمت 
Private Sub ListFind_Change() Dim i As Long With ListFind For i = .ListCount - 1 To 0 Step -1 Debug.Print i, ListFind.List(i, 0) If ListFind.List(i, 0) <> "" Then .ListIndex = i Exit For End If Next i End With End Sub  
تفعيل اخر صف في اللست بوكس.xls

جرب  هذا      الكود 
Sub RemoveFourthName() Dim R As Long, Temp As Variant, Arr As Variant Arr = Range("B2", Cells(Rows.Count, "B").End(xlUp)) For R = 1 To UBound(Arr) Temp = Split(Arr(R, 1), , 4) If InStr(Temp(3), " ") Then Temp(3) = Mid(Temp(3), InStr(Temp(3), " ") + 1) Arr(R, 1) = Join(Temp) Next Range("B2").Resize(UBound(Arr)) = Arr End Sub  
 

تفضل    لا تنسى  تغيير مسار  الملف  على  حسب  مكان  التخزين 
Sub Test() Dim sr As Workbook Set sr = Workbooks.Open("C:\Users\alhagag\Downloads\touati\touati1.xlsx", True, True) ThisWorkbook.Activate Worksheets("sheet1").Range("B2:E200").Value = sr.Worksheets("sheet1").Range("a2:d200").Value sr.Close End Sub  
touati.rar

لقد  تم  حل  ما طلبته   كان  من  المفترض   التوضيح  من  البداية  
تفضل  هذه  المعادلة 
=IFERROR(INDEX($A$2:$A$23;AGGREGATE(15;6;ROW($A$2:$A$23)-ROW($A$1)/(($B$2:$B$23>=$E$1)*($B$2:$B$23<=$G$1));ROW()-ROW($E$3)));"")  
إدراج الاسماء تلقائي.xlsx

جرب هذه  المعادلة  
=IF(OR(C6="";D6="");"";IF(AND(ISNUMBER(MATCH($C6;'Room Reservation'!$K$2:$K$6000;0));ISNUMBER(MATCH($D6;'Room Reservation'!$J$2:$J$6000;0)));"محجوزة";"غير محجوزة "))  
Hotel Reservation Daily000 (1).xlsm

المعادلة   تعمل   في  العمود  d        هذا  الملف   الذي   عملت  عليه   القيمة  الظاهرة 5   اذا   وجدت  خطا    المشكلة  من  عندك   
nour8161.xlsx

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

تم معالجة  الامر 
posting.xlsm