اذهب الي المحتوي
أوفيسنا

سليم حاصبيا

أوفيسنا
  • Content Count

    7,295
  • تاريخ الانضمام

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

  • Days Won

    151

سليم حاصبيا last won the day on مايو 23

سليم حاصبيا had the most liked content!

السمعه بالموقع

6,232 Excellent

عن العضو سليم حاصبيا

  • الإسم الفعلي
    فريق الموقع
  • تاريخ الميلاد 08 مار, 1985

البيانات الشخصية

  • Gender (Ar)
    ذكر
  • Job Title
    استاذ ثانوي
  • البلد
    beiruth
  • الإهتمامات
    eXCEL

اخر الزوار

10,406 زياره للملف الشخصي
  1. جرب هذا الملف العامود L اتركه فارغاً تماماً (حتى لا يؤثر على عمل الماكرو) MY_librery.xlsb لتعديل البيانات يمكنك راٍساُ تعديلها يدوياً ( بعد اجراء الفلتر) أو بواسطة ماكرو اخر
  2. تم معالجة الأمر البحث يتم بواسطة الرقم لا بالتاريخ (لضيق الوقت ) يمكنك التعديل اذا اردت البحث بالتاريخ Number_search.xlsm
  3. يمكنك استعمال هذا الماكرو ايضاُ (اذا كان الأمر يتعلق بخلية واحدة الماكرو الأول او عدة خلايا(نطاق) الماكرو الثاني Sub wrap_cel() Range("d1").WrapText = True End Sub '+++++++++++++++++++++++++++++++++ Sub wrap_range() Range("A1:C410").WrapText = True End Sub
  4. هذا الكود البسيط (استبدل الرقم 3 بالرقم الي تريده) Sub Wrap_col() Columns(3).AutoFit End Sub
  5. كل المعادلات عادية (بدون CTRL+SHIFT+ENTER) اذا اردت ان يكون تاريخ البداية والنهاية ضمن المجموع =SUMPRODUCT(($D$4:$D$13<=$I$4)*($D$4:$D$13>=$G$4)) اذا اردت ان لا يكونا ضمن المجموع =SUMPRODUCT(($D$4:$D$13<$I$4)*($D$4:$D$13>$G$4)) اذا اردت ان يكون احدهما ضمن الموحوع ( الأصغر فقط أو الأكبر فقط) =SUMPRODUCT(($D$4:$D$13<=$I$4)*($D$4:$D$13>$G$4))
  6. جرب هذا الكود Private Sub CommandButton2_Click() On Error Resume Next Range("a9").Resize(9).SpecialCells(4) _ .EntireRow.Delete Shift:=xlUp End Sub
  7. لا داعي لاي شيء فقط قم باخفاء الأعمدة التي لا تريدها مستعملاً هذا الماكرو Sub Hide_columns() Dim k% Sheets("Infos").Columns.Hidden = False Dim arr() arr = Array(3, 4, 5, 6, 7, 8, 9, 10) For k = LBound(arr) To UBound(arr) Sheets("Infos").Columns(arr(k)).Hidden = True Next End Sub في الصورة المرفقة حدد أرقام الأعمدة التي تريد اخفا ئها من خلال Array (تسلسل الأرقام داخل Array غير ضروري) Information_Advanced_Ar_date_1.xlsm
  8. تم التعديل اذا كان الرقم وحيداً يكتب بالعربية واذا كان مصحوباً مع اي شيء اخر اكسل يتعبره نصاّ لذلك لا يدرجه بالعربية Information_Advanced_Ar.xlsm
  9. تم التعديل على الكود كما تريد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then If Target = vbNullString Then Find_Hawiyya_ALL Else Find_Hawiyya End If End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++ Sub Find_Hawiyya() Dim Inf As Worksheet, Act_sh As Worksheet Dim s_rg As Range, find_rg As Range Dim Inf_rg As Range Dim Targ_rg As Range Dim Where_rg As Range Dim m%, Ro%, x%, N% Set Inf = Sheets("Infos") Set s_rg = Inf.Range("A2") N = Sheets.Count m = 8 Set Inf_rg = Inf.Range("A7").CurrentRegion Inf.Cells(2, 2) = vbNullString If Inf_rg.Rows.Count > 1 Then _ Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear 'If s_rg = vbNullString Then Exit Sub For x = 1 To N If Sheets(x).Name = Inf.Name Then GoTo Next_x Set Act_sh = Sheets(x) Set find_rg = Sheets(x).Range("D:D") Set Targ_rg = find_rg.Find(s_rg, Lookat:=1) If Not Targ_rg Is Nothing Then Ro = Targ_rg.Row Inf.Cells(m, 2).Resize(, 18).Value = _ Sheets(x).Cells(Ro, 2).Resize(, 18).Value Inf.Cells(m, 1) = m - 7 m = m + 1 End If Next_x: Next x If m = 8 Then MsgBox "No Data To Exract": Exit Sub Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count = 1 Then Exit Sub With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .Interior.ColorIndex = 19 End With Inf.Cells(2, 2) = Inf.Cells(8, "E") End Sub '++++++++++++++++++++++++++++++++++++ Sub Find_Hawiyya_ALL() Dim Inf As Worksheet Dim s_rg As Range Dim Inf_rg As Range Dim Where_rg As Range Dim m%, t%, x% Dim Dic As Object, ky Dim arr(11) Set Inf = Sheets("Infos") Set s_rg = Inf.Range("A2") Set Dic = CreateObject("Scripting.Dictionary") '============================ Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count > 1 Then _ Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear For t = 1 To 12: arr(t - 1) = t & "": Next m = 8 '======================= If s_rg <> vbNullString Then Exit Sub For x = 1 To Sheets.Count If IsError(Application.Match(Sheets(x).Name, arr, 0)) Then _ GoTo Next_x Set Where_rg = Sheets(x).Range("a1").CurrentRegion If Where_rg.Rows.Count = 1 Then GoTo Next_x Set Where_rg = Where_rg.Offset(1).Resize(Where_rg.Rows.Count - 1) For t = 1 To Where_rg.Rows.Count Dic.Add (t - 1), Where_rg. _ Rows(t).Cells(2).Resize(, 18).Value Next t For Each ky In Dic.keys Inf.Cells(m, 2).Resize(, 18) = Dic(ky) Inf.Cells(m, 1) = m - 7 m = m + 1 Next ky Next_x: Dic.RemoveAll Next x Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count = 1 Then Exit Sub With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .Interior.ColorIndex = 35 End With Inf.Cells(2, 2) = "ALL" End Sub الملف مرفق Information_Advanced.xlsm
  10. جرب هذا الكود تسمية الورقة الأولى باسم "Infos" لسهولة نسخ الكود ولصقه دون مشاكل اللغة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Find_Hawiyya End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++ Sub Find_Hawiyya() Dim Inf As Worksheet, Act_sh As Worksheet Dim s_rg As Range, find_rg As Range Dim Inf_rg As Range Dim Targ_rg As Range Dim Where_rg As Range Dim m%, Ro%, x%, N% Set Inf = Sheets("Infos") Set s_rg = Inf.Range("A2") N = Sheets.Count m = 8 Set Inf_rg = Inf.Range("A7").CurrentRegion Inf.Cells(2, 2) = vbNullString If Inf_rg.Rows.Count > 1 Then _ Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear If s_rg = vbNullString Then Exit Sub For x = 1 To N If Sheets(x).Name = Inf.Name Then GoTo Next_x Set Act_sh = Sheets(x) Set find_rg = Sheets(x).Range("D:D") Set Targ_rg = find_rg.Find(s_rg, Lookat:=1) If Not Targ_rg Is Nothing Then Ro = Targ_rg.Row Inf.Cells(m, 2).Resize(, 18).Value = _ Sheets(x).Cells(Ro, 2).Resize(, 18).Value Inf.Cells(m, 1) = m - 7 m = m + 1 End If Next_x: Next x If m = 8 Then MsgBox "No Data To Exract": Exit Sub Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count = 1 Then Exit Sub With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .Interior.ColorIndex = 19 End With Inf.Cells(2, 2) = Inf.Cells(8, "E") End Sub الملف مرغف Infomation.xlsm
  11. الآن فهمت عليك ماذا تريد (كي لا تظهر الاصفار في اي خلية ) بدون فورمات سيلس استبدل هذا السطر في الكود R.Cells(k, y).Value = My_sum: My_sum = 0 الى R.Cells(k, y).Value = IIf(My_sum = 0, "", My_sum): My_sum = 0
×
×
  • اضف...