اذهب الي المحتوي

سليم حاصبيا

أوفيسنا
  • Content Count

    6,109
  • تاريخ الانضمام

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

  • Days Won

    114

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

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

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

4,371 Excellent

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

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

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

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

اخر الزوار

8,204 زياره للملف الشخصي
  1. استبدل الى هذا الماكرو الذي يجد لك كلمة انتهى في اي عامود كانت و يقوم باخفاء الصفوف بعدها Sub hide_rows() Dim my_rg As Range Dim Copy_Rg As Range Dim find_Rg As Range Dim St$: St = "انتهى" Dim R%, Ro%, x%, Y% Dim t As Boolean show_all Application.ScreenUpdating = False ARCHIVE.Range("D2").CurrentRegion.Offset(1).Clear Set my_rg = Main.Range("D3").CurrentRegion For Y = 1 To my_rg.Columns.Count t = Not (IsError(Application.Match(St, my_rg.Columns(Y), 0))) If t Then Exit For End If Next Y If Not (t) Then GoTo LEAVE_ME_OUT x = my_rg.Rows.Count Set find_Rg = my_rg.Columns(Y).Find(St, after:=my_rg.Columns(Y).Cells(x)) If Not find_Rg Is Nothing Then R = find_Rg.Row: Ro = R Do If Copy_Rg Is Nothing Then Set Copy_Rg = Main.Range("b" & R).Resize(, 10) Else Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & R).Resize(, 10)) End If Set find_Rg = my_rg.FindNext(find_Rg) R = find_Rg.Row If Ro = R Then Exit Do Loop Copy_Rg.Copy ARCHIVE.Range("b2") Copy_Rg.EntireRow.Hidden = True ARCHIVE.Columns("b:k").AutoFit End If '+++++++++++++++++++++++++++++++++++++++++++++++ ARCHIVE.Range("b2").CurrentRegion.Sort _ key1:=ARCHIVE.Range("h2"), Header:=1 '++++++++++++++++++++++++++++++++++++++++++++++++ LEAVE_ME_OUT: Set my_rg = Nothing: Set find_Rg = Nothing Set Copy_Rg = Nothing Application.ScreenUpdating = True End Sub '============================================ Sub show_all() Application.ScreenUpdating = False Main.Rows.Hidden = False Application.ScreenUpdating = True End Sub الملف مرفق SAlim_2.xlsm
  2. تم التعديل على الكود Option Explicit Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean) Application.Volatile Dim rCell As Range, lCol# lCol = rColor.Interior.ColorIndex ColorFunction = 0 For Each rCell In rRange If rCell.Interior.ColorIndex = lCol Then _ ColorFunction = _ ColorFunction + IIf(SUM, Application.SUM(rCell), 1) Next rCell End Function
  3. UDF رائعة اخي علي لكن اليس هناك من مجال لاختصارها دون الحاجة الى (vResult) لتبدو بهذا الشكل Option Explicit Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean) Dim rCell As Range, lCol# lCol = rColor.Interior.ColorIndex ColorFunction = 0 For Each rCell In rRange If rCell.Interior.ColorIndex = lCol Then _ ColorFunction = _ ColorFunction + IIf(SUM, Application.SUM(rCell), 1) Next rCell End Function
  4. و ما هو امتداد الملف الذي تريد رفعه الامتداد هو ما بعد النقطة في اسم الملف اسم الملف Find_first_cell_in Row .xlsm الامتداد هو xlsm اسم لم يكن اسم الامتداد في لائحة الرسالة لا يمكن رفع الملف
  5. جرب هذا الماكرو Option Explicit Rem =====>> created by Salim Hasbaya 13/7/2019 Sub Get_Data_Please() '========================== Dim Source_Sh As Worksheet Dim Target_Sh As Worksheet Dim LRS%, LRT%, RG_S As Range, RG_T As Range Dim cel As Range, My_adrs As Range '========================== Set Source_Sh = Sheets("DATA") Set Target_Sh = Sheets("TAB") LRS = Source_Sh.Cells(Rows.Count, 2).End(3).Row LRT = Target_Sh.Cells(Rows.Count, 3).End(3).Row Set RG_S = Source_Sh.Range("b3:M" & LRS) Set RG_T = Target_Sh.Range("C4:E" & LRT) Target_Sh.Range("F4:H" & LRT).ClearContents On Error Resume Next For Each cel In RG_T On Error Resume Next Set My_adrs = RG_S.Find(cel, lookat:=1) On Error GoTo 0 If Not My_adrs Is Nothing Then cel.Offset(, 3) = Source_Sh.Cells(My_adrs.Row, 2) End If Next End Sub الملف مرفق ب جدول - Copy.xlsm
  6. ارفع ملفاً جديداً يحتوي عما تريد أقله 10 صفوف من البيانات مع النتيجة المتوقعة ( يدوياً)
  7. استبدل هذا السطر في الكود R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7")).Row بهذا R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7"),Lookat:=Xlwhole).Row Xlwhole هنا حرف الـــ L باللغة الانكليزية وليس رقم 1 اذا كان هذا الجواب الكود يفي بالغرض اضغط على افضل اجابة لإغلاق الموضوع
  8. Saerch By two ways اعرض الملف يمكن عمل بحث في جدول بطريقة الاسم او الرقم صاحب الملف سليم حاصبيا تمت الاضافه 13 يول, 2019 الاقسام معلومات مفيدة  
  9. Version 1.0.0

    0 تنزيل

    يمكن عمل بحث في جدول بطريقة الاسم او الرقم
  10. تم ازالة بعض الخلايا المدمجة لحسن عمل الكود مجرد ان تدخل الاسم او الرقم يقوم الكود بعمله واذا كان هناك خطأ يعطيك اشعاراً بذلك الكود Option Explicit Private source_sh As Worksheet Private Target_sh As Worksheet Private Last_row% Private RG_Source As Range Private R1% Rem =====>> created by Salim Hasbaya 13/7/2019 Sub Get_Data_By_name() Set source_sh = Sheets("ورقة2") Set Target_sh = Sheets("ورقة1") Union(Target_sh.Range("D8"), Range("c12").Resize(, 5)).ClearContents Last_row = Application.Max(source_sh.Range("D:D")) + 6 Set RG_Source = source_sh.Range("b6:d" & Last_row) On Error Resume Next R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7")).Row On Error GoTo 0 If R1 = 0 Then MsgBox "DATA nOT FOUND": Exit Sub Else With Target_sh .Range("C12") = .Range("D7") .Range("D8") = source_sh.Cells(R1, "C") .Range("F12") = .Range("D8") .Range("G12") = source_sh.Cells(R1, "D") End With End If End Sub Rem ------------------------------------------- Sub Get_Data_By_Index() Set source_sh = Sheets("ورقة2") Set Target_sh = Sheets("ورقة1") Union(Target_sh.Range("D7"), Range("c12").Resize(, 5)).ClearContents Last_row = Application.Max(source_sh.Range("D:D")) + 6 Set RG_Source = source_sh.Range("b6:d" & Last_row) On Error Resume Next R1 = RG_Source.Columns(2).Find(Target_sh.Range("D8"), lookat:=xlWhole).Row On Error GoTo 0 If R1 = 0 Then MsgBox "DATA NOT FOUND": Exit Sub Else With Target_sh .Range("D7") = source_sh.Cells(R1, "B") .Range("C12") = .Range("D7") .Range("F12") = .Range("D8") .Range("G12") = source_sh.Cells(R1, "D") End With End If End Sub Rem +++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Count = 1 Then Select Case Target.Address Case "$D$7": Get_Data_By_name Case "$D$8": Get_Data_By_Index End Select End If Application.EnableEvents = True End Sub Archive2019.xlsm
  11. للاسف لا أجيد التعامل مع مع Google Sheet ربما ذلك يتطلب برمجة خاصة داخل ال Google نفسه
×
×
  • اضف...