اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

AbuuAhmed

الخبراء
  • Posts

    919
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    16

كل منشورات العضو AbuuAhmed

  1. حل آخر بدون كود vba: =IF(RIGHT(A1,1)="-",VALUE(TRIM(LEFT(A1,LEN(A1)-1)))*-1,VALUE(TRIM(A1))) المثال لا يوجد به أرقام بالموجب لذلك لا أضمن المعادلة ستنجح مع الأرقام الموجبة أو لا. العلامة بالسالب_01.xlsx
  2. كذلك اسم النموذج مختلف فالاسم في الكود UserForm وأنت مسميه UserForm1 فالتعديل بيكون بتبديل أول سطرين من: Private Sub UserForm_Initialize() With ListView1 إلى: Private Sub UserForm1_Initialize() With tbl
  3. تقريبا الخطأ شبيها للخطأ السابق، ولكن لو رفعت الصورة كالأولى عندما تنهي هذه الرسالة سيشير المؤشر على السطر والكائن المفقود أو اسم الكائن الخاطئ. كذلك لو تعطيني السيناريو أي الخطوات التي أدت لظهور هذا الخطأ حتى يحدث معي وأقوم بتتبعه. يبدو لي أنت مستقطع الكود من ملف آخر.
  4. لم أرى إلا نطاق tbl فاستخدمته بدلا من ListView1 كما أنه في آخر سطر مناداة لإجراء غير موجنود فعطلته actualistion. Private Sub UserForm_Initialize() 'With ListView1 With tbl .Gridlines = True 'affiche ou pas les lignes .View = lvwReport ' style de rapport .FullRowSelect = True ' permet de sélectionner une ligne dans la liste 'création des en-tétes personnalisées avec leur largeur .ColumnHeaders.Add Text:="الرقم", Width:=1 .ColumnHeaders.Add Text:="إسم المستفيد", Width:=60 .ColumnHeaders.Add Text:="حساب المستفيد", Width:=90 .ColumnHeaders.Add Text:="البنك", Width:=60 .ColumnHeaders.Add Text:="المبلغ", Width:=60 .ColumnHeaders.Add Text:="رقم الصك", Width:=60 .ColumnHeaders.Add Text:="تاريخ إجراء المعاملة", Width:=60 End With 'Call actualistion 'on appelle la procédure qui actualise la listview End Sub
  5. والله أتعبني الموضوع، أخي يفترض أن يكون سعر البيع المطلوب للبيع (متوسط الأسهم حالياً) يدخل يدويا وليس معادلة. جرب وخبرني. 111_01.xlsx
  6. وأينك عن هذا الموضوع؟!! .. لا بد متابعة مواضيعك، ارجع للموضوع السابق وضع ملاحظاتك قبل فتح موضوع جديد.
  7. في موضوع آخر هناك دوال لتأخذ تاريخين بداية ونهاية ثم ترجع المدة على شكل سنة شهر يوم أما هذه الدالة تأخذ أيام فقط وتحولها إلى سنة شهر يوم، وهنا الدالة تفترض أن تاريخ البداية دائما هو بداية دورة الـ 400 سنة مثل: 1، 401، 801، 1201، 1601، 2001 وهكذا. Function FixVal(inVal As Double, MinVal As Double, MaxVal As Double) As Double FixVal = inVal If inVal < MinVal Then FixVal = MinVal If inVal > MaxVal Then FixVal = MaxVal End Function Function Days2Period(ByVal Days As Long) As String Dim CurCal As VbCalendar Dim Gr2: Gr2 = Array(0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365, 396) Dim yy As Long, mm As Integer, dd As Integer Dim Cyc400 As Long, Cyc100 As Long, Cyc004 As Long, Cyc001 As Long Dim mmDays As Double, Leap As Byte CurCal = Calendar Calendar = vbCalGreg Cyc400 = Fix(Days / 146097): Days = Days - Cyc400 * 146097 Cyc100 = FixVal(Fix(Days / 36524), 0, 3): Days = Days - Cyc100 * 36524 Cyc004 = FixVal(Fix(Days / 1461), 0, 24): Days = Days - Cyc004 * 1461 Cyc001 = FixVal(Fix(Days / 365), 0, 3): Days = Days - Cyc001 * 365 yy = Cyc400 * 400 + Cyc100 * 100 + Cyc004 * 4 + Cyc001 mm = FixVal(Round(Days / 29.5, 0), 0, 11) Leap = Day(DateSerial(yy + 1, 3, 0)) - 28 mmDays = Gr2(mm) + IIf(mm > 1, Leap, 0) Do While mmDays > Days mm = mm - 1 mmDays = Gr2(mm) + IIf(mm > 1, Leap, 0) Loop dd = Days - mmDays Days2Period = Format(yy, "00") & "-" & Format(mm, "00") & "-" & Format(dd, "00") Calendar = CurCal End Function Days_to_Year_Month_Day_01.xlsm
  8. شكرا أخي لمشاركتك الكريمة، هنا تكمن المشكلة أخي الفاضل. مشكلة ستجدها مشتركة في كل الحلول كما أعتقد.
  9. دالة من "أبو هاجر" Function GetPeriod2(ByVal DateFm As Date, ByVal DateTo As Date, _ Optional yy As Integer, Optional mm As Byte, Optional dd As Byte) As String Dim TempDate As Date Dim m As Long DateFm = DateFm - 1 m = DateDiff("m", DateFm, DateTo) TempDate = DateAdd("m", m, DateFm) If TempDate > DateTo Then m = m - 1 TempDate = DateAdd("m", m, DateFm) End If yy = Fix(m / 12) mm = m Mod 12 dd = DateDiff("d", TempDate, DateTo) GetPeriod2 = Format(yy, "00") & "-" & Format(mm, "00") & "-" & Format(dd, "00") End Function دالة من جعفر Function YMDDif(ByVal sDate1 As Date, ByVal sDate2 As Date) As String Dim iYear As Integer Dim iMonth As Integer Dim iDay As Integer Dim dInterim1 As Date Dim D As Integer Dim m As Integer Dim Y As Integer sDate1 = sDate1 - 1 iMonth = DateDiff("m", sDate1, sDate2) If day(sDate1) > day(sDate2) Then iMonth = iMonth - 1 End If dInterim1 = DateAdd("m", iMonth, sDate1) iDay = DateDiff("d", dInterim1, sDate2) Y = iMonth \ 12 m = iMonth Mod 12 D = iDay YMDDif = Format(Y, "00") & "-" & Format(m, "00") & "-" & Format(D, "00") End Function دالة من "أبو هادي" Function GetPeriod1(ByVal DateFm As Date, ByVal DateTo As Date, _ Optional yy As Integer, Optional mm As Byte, Optional dd As Byte) As String Dim yyFm As Long, yyTo As Long Dim mmFm As Integer, mmTo As Integer Dim ddFm As Integer, ddTo As Integer DateFm = DateFm - 1 yyFm = Year(DateFm): mmFm = month(DateFm): ddFm = day(DateFm) yyTo = Year(DateTo): mmTo = month(DateTo): ddTo = day(DateTo) If ddFm = day(DateSerial(yyFm, mmFm + 1, 1) - 1) Then ddFm = 0: mmFm = mmFm + 1 End If If ddTo = day(DateSerial(yyTo, mmTo + 1, 1) - 1) Then ddTo = 0: mmTo = mmTo + 1 End If If ddTo - ddFm < 0 Then '(1) ddTo = ddTo + day(DateSerial(yyTo, mmTo, 0)): mmTo = mmTo - 1 If ddTo - ddFm < 0 Then '(2) ddTo = ddTo + day(DateSerial(yyTo, mmTo, 0)): mmTo = mmTo - 1 End If End If If mmTo < mmFm Then mmTo = mmTo + 12: yyTo = yyTo - 1 End If yy = yyTo - yyFm mm = mmTo - mmFm dd = ddTo - ddFm GetPeriod1 = Format(yy, "00") & "-" & Format(mm, "00") & "-" & Format(dd, "00") End Function
  10. كل دالة لحساب الأعمار لا تعطي هذه النتائج فهي تحتاج إلى مراجعة. علما أن هذه النتائج من دالة تعطي ناتج طرح تاريخ من نفسه يوما واحدا وليس صفرا، ولتكون المقارنة عادلة للدوال التي تعطي صفرا عليهم بطرح يوم من تاريخ البداية. ' DateFm DateTo Period '28/02/2010 01/02/2015 04-11-05 '01/03/2010 01/02/2015 04-11-04 '02/03/2010 01/02/2015 04-11-03 '03/03/2010 01/02/2015 04-11-02 '04/03/2010 01/02/2015 04-11-01 '05/03/2010 01/02/2015 04-11-00 '06/03/2010 01/02/2015 04-10-27 جربوا دوالكم وزودونا بنائجها.
  11. لا أعلم إذا يوجد في الاكسل أم لا. هذه دالة بالـ vba يمكنها أن تؤدي الغرض: Function Between(Value As Variant, MinVal As Variant, MaxVal As Variant) As Variant If VarType(Value) = VarType(MinVal) And _ VarType(Value) = VarType(MaxVal) Then Between = CBool(Value >= MinVal And Value <= MaxVal) Else Between = "Var type error" End If End Function
  12. لا بد تدخل على تنسيق خلية المدة وتجعلها نص. Calcul IEP_06.xlsm
  13. وعليكم السلام احذف اسم الدالة VALUE لتصبح النتيجة نص بدلا من رقم كذلك المدخل Period للدالة calcIEP من Double إلى String لتصبح الدالة بشكلها النهائي: Function calcIEP(ByVal Period As String) As Double Dim yr(), yy As Byte, mm As Byte Dim Pr(), Per As Double, P As Byte yr = Array(6, 5, 10, 5) Pr = Array(0.02, 0.018, 0.015, 0.04) P = InStrRev(Period, ".") mm = IIf(P = 0, 0, Mid(Period, P + 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_05.xlsm
  14. - قف على أي خلية بها رقم وانسخ الفاصلة العشرية - ظلل عمود الأرقام - اعمل عملية استبدال للكل من صندوق البحث بعد لصق الفاصلة المنسوخة وفي صندوق النص البديل ضع الفاصلة حسب قسم الأرقام من لوحة المفاتيح. ستتحول كل البيانان النصية إلى رقمية وستضطر إلى عملية تنسيق رقمي للعمود. أو استخدم هذه الشفرة: Sub Macro1() Sheets("101").Select If Asc(Mid(Range("C2"), Len(Range("C2")) - 2, 1)) <> 63 Then MsgBox "يبدو أنه قد تمت المعالجة من قبل" Exit Sub End If Columns("C:C").Select Selection.Replace What:=Mid(Range("C2"), Len(Range("C2")) - 2, 1), Replacement:=".", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.NumberFormat = "#,##0.00" MsgBox "Done" End Sub
  15. أدخلت تعديل على الدالة ولكن هي تعمل بنفس الأسلوب التعديل أن تعطي القيمة "" في حالة عدم وجود وحدة القياس وتعطي الناتج بالسالب في حالة لم يجد نفس الوحدة. صاحب الموضوع يا أنه تاه أو أنه مل، إن شاء الله يرجع لنا سريعا. Function getBalance(DumpVal) As Variant Dim sht1 As Worksheet, main As Worksheet Dim lrow As Integer, row As Integer Dim unit As String Set sht1 = Sheets("ورقة1") Set main = Sheets("رئيسي ") getBalance = "" With sht1 lrow = .Range("B1").End(xlDown).row unit = Trim(.Cells(lrow, 3)) If unit = "" Then Exit Function getBalance = -.Cells(lrow, 2) End With With main lrow = .Range("B1").End(xlDown).row For row = lrow To 2 Step -1 If .Cells(row, 1) Like "*" & unit Then getBalance = .Cells(row, 2) + getBalance Exit For End If Next row End With Set sht1 = Nothing Set main = Nothing End Function getBalance_07.xlsm
  16. حياك الله أستاذ @محمد هشام. هذه دالتي بعد فهمي لشرحك وإضافتك مزيد من البيانات المتنوعة. Function getBalance(DumpVal) As Long Dim sht1 As Worksheet, main As Worksheet Dim lrow As Integer, row As Integer Dim unit As String Set sht1 = Sheets("ورقة1") Set main = Sheets("رئيسي ") With sht1 lrow = .Range("B1").End(xlDown).row unit = .Cells(lrow, 3) getBalance = .Cells(lrow, 2) End With With main lrow = .Range("B1").End(xlDown).row For row = lrow To 2 Step -1 If .Cells(row, 1) Like "*" & unit Then getBalance = .Cells(row, 2) - getBalance Exit For End If Next row End With Set sht1 = Nothing Set main = Nothing End Function getBalance_04.xlsm
  17. يبدو أن الأستاذ محمد هشام فهم ما فهمته أنا أيضا لأن معادلته تعطي نفس ناتج دالتي. لقد قمت بالتعديل على الدالة بتمرير قيمة مهملة فقط لتشعر بأي تغيير في الصفحتين وتقوم بالحساب الذاتي. Function getBalance(DumpNum) As Long getBalance = Sheets("رئيسي ").Range("B1").End(xlDown) - _ Sheets("ورقة1").Range("B1").End(xlDown) End Function getBalance_02.xlsm
  18. حياك الله أخي، لقد شرحت الكود في المشاركة السابقة، وها أنا أضع لك التعديل مرة أخرى لتركز فيه أكثر: '---------------------------------------- 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 ويعني الخلايا الفاضية. وهذ كذلك لا تلمسه بالمرة. بالنسبة لوظيفة الكود لم أحاول فهمه وخصوصا من بصمته تعرفت على كاتبه وهو من الخبراء المتمكنين والذي لا يمكنني أن أعدل على أكواده، فرجاءً تواصل معه لأي تعديل منعا للإحراج. تحياتي واعتذاري.
  19. عمل لك دالة بالكود Function getBalance() getBalance = Sheets("رئيسي ").Range("B2").End(xlDown) - _ Sheets("ورقة1").Range("B2").End(xlDown) End Function getBalance_01.xlsm
  20. على قد فهمي فأنا محسوب على منتدى الأكسس وكثير من أوامر ودوال الاكسل لا أستخدمها. 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
  21. اختصار للكود 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
  22. تم تحويل نتائج الدالة إلى نص كما تحب. Option Explicit Function Frac(Num As Variant) As Double Frac = Num - Fix(Num) End Function Function ArrivalTimeDiff(ByVal ScheduledArrival As Variant, _ ByVal ActualArrival As Variant) As Variant Dim TimeDiff As Double ArrivalTimeDiff = "" If Not IsDate(ActualArrival) And Not IsNumeric(ActualArrival) Then Exit Function If Not IsDate(ScheduledArrival) And Not IsNumeric(ScheduledArrival) Then Exit Function If Trim(ActualArrival) = "" Or Trim(ScheduledArrival) = "" Then Exit Function ScheduledArrival = Frac(ScheduledArrival) * 24 ActualArrival = Frac(ActualArrival) * 24 TimeDiff = ActualArrival - ScheduledArrival If Abs(TimeDiff) >= 18 Then If ActualArrival < ScheduledArrival Then ActualArrival = ActualArrival + 24 Else ScheduledArrival = ScheduledArrival + 24 End If TimeDiff = ActualArrival - ScheduledArrival End If 'ArrivalTimeDiff = TimeDiff ArrivalTimeDiff = IIf(TimeDiff < 0, "-", " ") & Format(Abs(TimeDiff) / 24, "h:mm") End Function Trips Schedule_03.xlsm
  23. أسهبت في الشرح ولم تذكر نتائج محاولتي!! هذه آخر مشاركة لي مع الإعتذار، ولأترك الفرصة لغيري. ملاحظاتي: - ليكون عملك بشكل متقن ومتين يجب الإدخال يكون تاريخ ووقت، فستتجنب كثير من متاعب المعالجة والدخول في متاهات الإحتمالات. - لا تقم بعمل ما يخالف المعايير البرمجية كإظهار نتائج الوقت بالسالب، وكما قلت لك سابقا يمكن عملها ولكن من واجبنا أن ننصحك قبل أن نرضيك. بالنسبة لعمود الدقائق لم يكن له علاقة بالدالة وإنما أضفته "لقافة" مني كعمود مساعد للتوضيح فقط، فالحل هو في عمود الساعات فقط. من الجيد أن تتألم قليلا لعملية علاج بدلا من استمرار العلة ومواجهة المتاعب المستمرة.
×
×
  • اضف...

Important Information