سليم حاصبيا

كي يعمل الكود بشكل ممتاز يجب ازالة اشد اعداء الـــ VBA اعني الخلايا المدمجة

جرب هذا الكود (اعتقد انه اسرع و لايحتاج الى حلفات تكرارية) Sub filter_for_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("المصدر") Dim T_sh As Worksheet: Set T_sh = Sheets("الهدف") Dim My_Table As Range: Set My_Table = S_sh.Range("A1").CurrentRegion T_sh.Range("a1").CurrentRegion.ClearContents T_sh.Range("s2").Formula = "=المصدر!$H2=الهدف!$L$1" My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("s1:s2"), _ CopyToRange:=T_sh.Range("A1") T_sh.Range("s2").ClearContents With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$L$1" Or Target.Count > 1 Then GoTo 1 Application.EnableEvents = False filter_for_ME 1: Application.EnableEvents = True End Sub الملف مرفق بصيغة 2003 كي يستفيد منه العدد الاكبر من الاعضاء استدعاء صفحة كامله .. بشرط salim.rar

بعد اذن اخي زيزو هذا الكود من سطرين فقط Option Explicit Sub Filter_Me() Sheets("ورقة2").Range("a1").CurrentRegion.ClearContents Sheets("ورقة1").Range("a1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("ورقة2").Range("m1:n2"), copytorange:=Sheets("ورقة2").Range("a1") End Sub الملف مرفق المصنف1 Salim.rar

جرب هذا الملف اظهار النجمة للفراغ salim.rar

في المثال عندك 1-انسخ العناوين الى النطاق K1:S1 2- انسخ هذا الكود ثم قم بتنفيذه Option Explicit Sub give_data() Dim i%, k%, m% i = 2 m = 2 Range("K2").CurrentRegion.Offset(1).ClearContents Do Until Cells(i, 1) = vbNullString For k = 1 To 8 If Cells(i, 1).Offset(0, k) <> 0 Then Cells(m, "k").Resize(, 9).Value = Cells(i, 1).Resize(, 9).Value m = m + 1 Exit For End If Next i = i + 1 Loop End Sub

تم التعديل تصفية البيانات salim.rar

جرب هذا الماكرو Sub give_data() Dim i%, k%, m% i = 2 m = 2 Do Until Cells(i, 1) = vbNullString For k = 1 To 3 If Cells(i, 1).Offset(0, k) <> 0 Then Cells(m, "f") = Cells(i, 1).Value m = m + 1 Exit For End If Next i = i + 1 Loop End Sub

لقد وضعت الكود لطريقة ايجاد أول سجل و اخر سجل و لك عمليةالتحديد فقط استبدال MsgBox First_Address بــــــــــــــــــ: Range(First_Address).Select على كل حال تم عمل المطلوب Aziz Sallim.rar

اليك الملف مع المعادلة Book1 salim21.rar

هذا الكود يقوم يظهر لك اول خلية واخر خلية في الجدول بعد التصفية Sub LastFR() Dim FinalRowFiltered As Long, DataRange As Range Dim First_Address As String Dim Final_Adddres As String Dim lr%, i% lr = Cells(Rows.Count, 1).End(3).Row Set DataRange = Range("A3:c" & lr) With DataRange.SpecialCells(xlCellTypeVisible) FinalRowFiltered = .Areas(.Areas.Count).Row + .Areas(.Areas.Count).Rows.Count - 1 Final_Adddres = Range("a" & FinalRowFiltered).Address End With For i = 3 To lr If Rows(i).Hidden = False Then First_Address = Cells(i, 1).Address Exit For End If Next MsgBox First_Address MsgBox Final_Adddres End Sub

ربما تكون المعادلة الصحيحة =IF(ROWS($A$1:A1)-1>YEAR($B$2)-YEAR($B$1),"",IF(MAX(YEAR($B$1),YEAR($B$2))=F2,ROUND(($B$2-DATE(YEAR($B$2),1,1))/30.45,1),IF(MIN(YEAR($B$1),YEAR($B$2))=F2,ROUND((DATE(F2,12,31)-$B$1)/30.45,1),12)))

كيف تريد ان ترحل بيانات من جدول فارغ؟؟؟؟؟

تم التعديل حسب ما تريد (انظر الى الصفحة Salim) Book1 salim3.rar

محاولة Book1 salim.rar

في الخلية H5 هذا المعادلة و اسحب نزولاَ =IF(COUNTA(A$5:E$5)<5,0,4*SUM(C$5:D$5)*(Q$6-R$6)*T$6)

انظر الى العامود الاصفر من هذا الملف Ali Salem1.rar

جرب هذا الملف Ali Salem.rar

الكود يتجدث عن("Sheets("Master الذي لا وجود له

الملف مرفق مع الكود exemple salim.rar

اليك هذا الماكرو لضبط المشكلة Option Explicit Sub give_real_value() Application.ScreenUpdating = False Dim cel As Range For Each cel In Sheets("Feuil1").Range("a1").CurrentRegion cel.Value = Left(cel.Value, 4) Next With Sheets("Feuil1").Range("a1").CurrentRegion .HorizontalAlignment = 3 .VerticalAlignment = 3 End With Application.ScreenUpdating = True End Sub

الملف مع الكود تم وضعه بصيغة 2003 كي يستفيد منه الجميع Aziz1سليم.rar

جرب هذا الماكرو Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 3 Then With Application .EnableEvents = True End With Exit Sub End If Dim lr% Application.EnableEvents = False lr = Application.Max(Range("a:a")) If Target.Row > lr Or Target.Cells.Count > 1 Then With Application .EnableEvents = True End With Exit Sub End If If Target.Value = "اداري" Then Target.Offset(0, 1).Select If Target.Value = "معلم" Then Target.Offset(0, 3).Select With Application .EnableEvents = True End With End Sub

لم افهم من المطلوب بعد الاطلاع على الملف سوى عبارة"يقوم ببعثرة للقيم الموجودة في العمود c1 "

اذا كانت If وجوابها بعد Then في نفس السطر لا حاجة الى end if

هذا الكود Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If ActiveSheet.Name = "Sheet1" Then Exit Sub If ActiveCell.Address = "$G$1" Then Sheets("Sheet1").Activate End Sub