نجوم المشاركات

وعليكم السلام ورحمة الله تعالى وبركاته Public Sub CopyData() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") Col_Star = 10: Col_Search = 18: Clé1 = desWS.[R12]: Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False If Len(Clé1) > 0 And Len(Clé2) > 0 Then desWS.Range("C14:U" & Rows.Count).ClearContents Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSData = Sheets(Sh(i)) With WSData .AutoFilterMode = False Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow If WSData.Cells(Rng, Col_Search).Value = Clé1 Then rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSData.Cells(Rng, Cpt(c)).Value Next c End If Next Rng rngFound.AutoFilter Field:=16, Criteria1:=Clé1 Set rngSearch = WSData.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then rngSearch.Offset(1).Resize(ligne - 1).Copy desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub ترحيل الدرجات v2.xlsm

ليس هذا ما اريده .. أرسلت لك مرفقا به مواد درجاتها مرصودة وأخرى غير مرصودة للتمييز مشاركة مع الاساتذة ..... ضع هذا الفانك في النموذج Function CountFields() Set db = CurrentDb() Set RS = db.OpenRecordset("SELECT tb_1.[لغة عربية], tb_1.رياضيات, tb_1.علوم, tb_1.[تربية إسلامية], tb_1.[دراسات اجتماعية] FROM tb_1;") RS.MoveFirst Do While Not RS.EOF Countt = 0 For Each Item In RS.Fields If RS.Fields(Item.Name).Value <> "" Then Countt = Countt + 1 Next Item RS.MoveNext Loop [نص35] = Countt End Function واستدعيه من حدث الحالي للنموذج بهذا الشكل CountFields جرب واعلمنا هل هذا هو المطلوب <<<<<<<<<<<<<<<<<<

حياك الله أخي، لقد شرحت الكود في المشاركة السابقة، وها أنا أضع لك التعديل مرة أخرى لتركز فيه أكثر: '---------------------------------------- Col = 2 'العمود الثاني .. رقم الجلوس 'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر lr = Cells(Rows.Count, Col).End(xlUp).Row 'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks) '---------------------------------------- من الطبيعي إذا بدلت في الأرقام دون معرفتها ومعرفة جدواها ستوقف الكود. توضيح للأرقام: الرقم 2 هو رقم عمود رقم الجلوس وهو الرقم الوحيد الذي يمكنك التعديل عليه عند إزاحة/تغيير موقع العمود وبشرط أن لا تستخدم أسفل العمود أي يكون عند نهاية خاليا حتى نهاية الصفحة. الرقم 3 هو قيمة الرمز xlUp ويعني للأعلى، وهذا لا تلمسه بالمرة. الرقم 4 هو قيمة الرمز xlCellTypeBlanks ويعني الخلايا الفاضية. وهذ كذلك لا تلمسه بالمرة. بالنسبة لوظيفة الكود لم أحاول فهمه وخصوصا من بصمته تعرفت على كاتبه وهو من الخبراء المتمكنين والذي لا يمكنني أن أعدل على أكواده، فرجاءً تواصل معه لأي تعديل منعا للإحراج. تحياتي واعتذاري.

على قد فهمي فأنا محسوب على منتدى الأكسس وكثير من أوامر ودوال الاكسل لا أستخدمها. Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range, k% Dim In_box, Col As Integer Application.ScreenUpdating = False If ActiveSheet.Name <> "m" Then GoTo End_Me del_Empty_rows In_box = Application.InputBox("How Many Rows", , 14) a = In_box - 1 'number of rows for every group z = 3 'number of rows to be insert every time x = 8 'first row to begine If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 '---------------------------------------- 'العمود الثاني Col = 2 'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر 'lr = Cells(Rows.Count, 2).End(3).Row lr = Cells(Rows.Count, Col).End(xlUp).Row 'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني 'Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4) On Error Resume Next Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks) '---------------------------------------- my_rg.EntireRow.Delete On Error GoTo 0 Do Until Cells(t, "B") = "" Rows(t).Resize(z).Insert Sheets("m").Range("My_DEB").Copy _ Cells(t, 1) t = t + a + z + 1 Loop End_Me: Application.ScreenUpdating = True End Sub

اختصار للكود Function calcIEP(ByVal Period As Double) As Double Dim yr(), yy As Byte, mm As Byte Dim Pr(), Per As Double, Pos As Byte, p As Byte yr = Array(6, 5, 10, 5) Pr = Array(0.02, 0.018, 0.015, 0.04) Pos = InStrRev(Period, ".") mm = IIf(Pos = 0, 0, Mid(Period, Pos + 1)) Period = Fix(Period) For p = 1 To 4 yy = yr(p - 1): Per = Pr(p - 1) If Period > yy And p < 4 Then Period = Period - yy calcIEP = calcIEP + yy * Per Else calcIEP = calcIEP + Period * Per + (Per / 12 * mm) Exit For End If Next p End Function تم تنقيح الكود وتغيير المرفق. Calcul IEP_03.xlsm

تفضل اخي حاولت قدر الامكان اختصار الكود بطريقة ابسط نوعا ما ليسهل التعامل معه والتعديل عليه للضرورة مع توضيح بعض النقاط المهمة Sub GetPrice3() Dim WSitems As Worksheet, WSPrice As Worksheet, dest As Worksheet, ws As Worksheet Dim s As Range, Title As Range, r As Range, Rng As Range, ShtDate As Date, MaxDate As Date Dim c As Range, f As Range, a&, XPric As String, Clé As Range Set WSitems = ThisWorkbook.Sheets("items") Set dest = Worksheets("itemout") 'B4 'استخراج اسم قائمة الاسعار بشرط التاريخ المدخل في الخلية XPric = dest.Range("E4"): Set Title = dest.[B8:B32] If Len(dest.Range("B4").Value) = 0 Then: MsgBox "يجب عليك إدخال التاريخ", vbExclamation: Exit Sub If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= dest.Range("B4").Value And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & dest & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else 'تعريف الورقة الهدف Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) End If End If 'التحقق من ادخال كود الصتف If Application.WorksheetFunction.CountA(dest.Range("B8:B32")) = 0 Then MsgBox "المرجوا ادخال كود الصنف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin" Exit Sub End If With Application .EnableEvents = False .ScreenUpdating = False If WSPrice.FilterMode Then WSPrice.ShowAllData ' البحث عن عمود نوع التعامل Set Clé = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, _ LookAt:=xlWhole) If Not Clé Is Nothing Then ' افراغ البيانات السابقة For a = 8 To 32 Union(dest.Range("A" & a), dest.Range("C" & a), dest.Range("G" & a & ":H" & a)).ClearContents Next a '******** ' جلب البيانات من القائمة************* ' بشرط كود الصنف عمود 'B' For Each r In dest.Range("B8", dest.Cells(Rows.Count, 2).End(xlUp)) 'D' البحث في قائمة الاسعار عمود Set Rng = WSPrice.Range("D:D").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then '7(G)' وضع السعر في عمود dest.Cells(r.Row, 7).Value = WSPrice.Cells(Rng.Row, Clé.Column).Value ' تحديد عود السعر بشرط الخلية 'E4 For Key = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row 'items'جلب اسم الصنف من ورقة Set Col = WSitems.Cells.Find(What:=dest.Range("B" & Key), LookAt:=xlPart) If Not Col Is Nothing And Col <> "" Then dest.Range("C" & Key) = Col.Offset(0, 1).Value Next Key End If Next ' تسلسل عمود 'A' For Each s In Title If s.Value <> "" Then J = J + 1: s.Offset(0, -1).Value = Format(J, "0") Next fRng = dest.Range("B" & dest.Rows.Count).End(xlUp).Row 'القيمة F*G With dest.Range("H8:H" & fRng) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With ' نسخ اسم قائمة السعر المستخدمة dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name Else MsgBox "نوع التعامل غير موجود" & _ vbCrLf & "", vbExclamation, XPric End If .EnableEvents = True .ScreenUpdating = True End With End Sub وكما سبق الذكر سابقا عند نسخك للكود على ملفك الاصلي تأكد من تطابق بيانات الخلية E4 مع رؤؤوس الأعمدة في أوراق قوائم الأسعار اليك الملف للتجربة price list officena V4.xlsm