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

سليم حاصبيا

أوفيسنا
  • Content count

    4,106
  • تاريخ الانضمام

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

  • Days Won

    55

سليم حاصبيا last won the day on July 10

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

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

2,622 Excellent

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

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

Profile Information

  • Gender (Ar)
    ذكر
  • Job Title
    استاذ ثانوي
  • Location
    beiruth
  • Interests
    eXCEL

اخر الزوار

3,583 زياره للملف الشخصي
  1. الملف جاهز ولكن يتطلب كودات جديدة لليوزر فورم الجديد Double_UserForm.rar
  2. اختيار عشوائى اسبوعى

    جرب هذا المرفق تم اضافة رقمين الى الجدول حتى يصبح 14 رقم موزعة على رقمين كل يوم الكود Option Explicit Sub Rand() Dim g(14), c, r, arr(), t$ ReDim arr(1 To 2) Do c = Application.RandBetween(1, 14) If Not g(c) Then r = r + 1 arr(r) = c t = "=INDEX($F$4:$F$17," & arr(r) & ")" Cells(r + 1, "a") = Evaluate(t) g(c) = True End If Loop Until r = 2 End Sub الملف Random_salim.rar
  3. جرب هذه الملف في النطاق A2:k11 (يمكن تعديل هذا النطاق من داخل الكود) الكود مرفق Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim my_rg As Range Dim col%, r%, x%, t% Application.EnableEvents = False Set my_rg = Range("a2:k11") If Intersect(Target, my_rg) Is Nothing Then GoTo 1 If Target.Rows.Count <> 1 Then GoTo 1 r = Target.Row: col = Target.Column t = Cells(r, 1).End(xlToRight).Column: If t > 11 Then t = 1 x = Application.CountA(Range(Cells(r, 1), Cells(r, col))) If x <> col Then MsgBox ("Out Of range") Target.Value = vbNullString If t = 1 Then Cells(r, 1).Select Else Cells(r, t + 1).Select End If End If 1: Application.EnableEvents = True End Sub الملف No_cells_to_skeep.rar
  4. ارفع الملف نفسه او نسخة(فارغة ) عنه اذ لا يمكن التعامل مع الصورة
  5. بعد اذن اخي ياسر جرب هذا الملف هناك 2 كود الاول في حدث الصفحة invoice Option Explicit Private Sub Worksheet_Activate() Dim answer% answer = MsgBox("هل تريد زيادة ترقيم الفاتورة", vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading + vbQuestion, "ُExcel Ask You") If answer = 6 Then Me.Range("d5") = Me.Range("d5") + 1 Me.Rows.Hidden = False End If End Sub الثاني في Mudule عادي Salim Option Explicit Sub Copy_Data() Dim Sh_To_Copy As Worksheet, Sh_To_Paste As Worksheet Dim Rg_Copy As Range Dim lrCopy%, Lrpast%, m%, My_Num%, i% Dim My_Str As String, Answer2% Set Sh_To_Copy = Sheets("invoice"): Set Sh_To_Paste = Sheets("recycle") Sh_To_Paste.Unprotect 11 Sh_To_Copy.Range("a9:f25").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True My_Str = Sh_To_Copy.Range("c5").Value My_Num = Sh_To_Copy.Range("d5").Value lrCopy = Sh_To_Copy.Cells(Rows.Count, 1).End(3).Row Lrpast = Sh_To_Paste.Cells(Rows.Count, 1).End(3).Row For i = 5 To Lrpast If Sh_To_Paste.Range("c" & i) = My_Str And Sh_To_Paste.Range("d" & i) = My_Num Then Answer2 = MsgBox("الفاتورة تحت هذا الرقم موجوده هل تريد استبدالها", vbYesNo) If Answer2 <> 6 Then Sh_To_Paste.Protect 11: Exit Sub Exit For End If Next Set Rg_Copy = Sh_To_Copy.Range("a5:F" & lrCopy).SpecialCells(12) m = Rg_Copy.Rows.Count Sh_To_Paste.Range("a5:a" & m + 8).EntireRow.Insert Rg_Copy.Copy Sh_To_Paste.Range("a5") Sh_To_Paste.Protect 11 End Sub Facture_salim.rar
  6. ترحيل من الفاتورة الى اسماء الزبائن

    اوضح ماذا تريد بلغة الاكسل 1-هل تريد ان يكون لكل اسم صفحة خاصة به؟ام ان الصغحة الواحدة يمكن ان تحتوي على عدة حسابات 2- يرجى عدم ترك اعمدة فارغة لان اكسل في هذه الحالة لا يعتير اليبانات كجدول واحد و بذلك تتعقد الامور على الكود 3- ادراج بعض البيانات و النتائج المتوقعة
  7. فصل البيان

    بعد اذن اخي ابو البراء بالمعادلات: في B2 ,اسحب نزولاً =LEFT(TRIM(A2),FIND("(",TRIM(A2))-1) في D2 اسحب نزولاً =SUBSTITUTE(MID(TRIM(A2),(FIND("*",TRIM(A2))),((FIND("سعر",TRIM(A2)))-(FIND("*",TRIM(A2)))-1)),"*","")+0
  8. يا أخي: لماذا لا تريد ان تصدق ان الكود يقوم ينسخ الخلايا المرئية فقط من الشيت recycle ,وينقلها الى الشيت invoice وذ لك بفضل ما هو باللون الاحمر في هذه 3 أسطر من الكود Worksheets("recycle").Range("a" & arr(x) & ":f" & arr2(x)).SpecialCells(xlCellTypeVisible).Copy Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteValues Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteFormats الصفحة الاساسية :recycle الصفحة المنقول اليها:invoice استبدل الكود بهذا كي لا تظهر( الساعة الرملية) اذا لم يكن في احد الفواتير "فاتورة مبيعات رقم" او "الاجمالي" فإن الكود يمسح البيانات من ورقة invoice و يتوقف عن العمل Option Explicit Sub Test_Me() Dim rngFind As Range Dim strFindMe$ Dim r%, r1%, x%, last_row%, k%, rr% Dim arr(), arr2() k = 1 last_row = 1 With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With On Error Resume Next Sheets("invoice").Cells.Clear strFindMe = "فاتورة مبيعات رقم" With Worksheets("recycle").Range("c:c") Set rngFind = .Find(what:=strFindMe, LookIn:=xlValues) If Not rngFind Is Nothing Then r = rngFind.Row ReDim Preserve arr(1 To k) arr(k) = r Do Until r = r1 Set rngFind = .FindNext(rngFind) r1 = rngFind.Row k = k + 1 ReDim Preserve arr(1 To k) arr(k) = r1 Loop End If ReDim Preserve arr(1 To k - 1) End With If r = 0 Then GoTo 1 '============================================ k = 1 r1 = 0: r = 0 strFindMe = "الاجمالي" With Worksheets("recycle").Range("a:f") Set rngFind = .Find(what:=strFindMe, LookIn:=xlValues) If Not rngFind Is Nothing Then rr = rngFind.Row ReDim Preserve arr2(1 To k) arr2(k) = rr Do Until r1 = rr Set rngFind = .FindNext(rngFind) r1 = rngFind.Row k = k + 1 ReDim Preserve arr2(1 To k) arr2(k) = r1 Loop End If ReDim Preserve arr2(1 To k - 1) End With If rr = 0 Then GoTo 1 If UBound(arr) <> UBound(arr2) Then GoTo 1 '============================================ For x = UBound(arr) To LBound(arr) Step -1 Worksheets("recycle").Range("a" & arr(x) & ":f" & arr2(x)).SpecialCells(xlCellTypeVisible).Copy Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteValues Sheets("invoice").Range("a" & last_row).PasteSpecial Paste:=xlPasteFormats last_row = Sheets("invoice").Cells(Rows.Count, 1).End(3).Row + 2 Next 1: Erase arr: Erase arr2: Set rngFind = Nothing: strFindMe$ = vbNullString With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Copy_Invoices Corriger.rar
  9. بعد اذن اخي ابو البراء هذا الكود(لا تدرج المعادلة اذا كانت الخلية فارغة) Option Explicit Sub create_formula() Dim my_rg As Range Dim Row%, i% Set my_rg = Range("d7").CurrentRegion Row = my_rg.Rows.Count + 6 my_rg.Offset(1, 0).Columns(3).ClearContents For i = 8 To Row If Not IsEmpty(Cells(i, 5)) Then Cells(i, 6).Formula = "=IF(OR(COUNTIF($I$8:$I$100," & Cells(i, 5) & ")=0," _ & Cells(i, 5) & "=""""),"""",VLOOKUP(" & Cells(i, 5) & ",$I$8:$J$100,2,0))" End If Next End Sub
  10. جرب هذه المعادلة في F8 واسحب نزولاُ =IF(OR(COUNTIF($I$8:$I$100,$E8)=0,$E8=""),"",VLOOKUP($E8,$I$8:$J$100,2))
  11. لا أعلم ما السبب عندك مع انه عندي يعمل بسرعة كيرة
  12. جرب هذا الكود عذراً بم اسنطع نحميل الكود بسبب بطء النت الملف مرفق Copy_Invoices.rar
  13. جرب هذه المعادلة في الخلية E2 واسحب نزولاً (يحب استعمال Ctrl+Shift+Enter و ليس Enter وحدها لانها معادلة صفيف) Array_Fromula) كما يجب نتسيق الخلايا في العامود E كتاريخ =INDEX(البيانات!$R$2:$AD$1000,MATCH(الخلاصة!A2,البيانات!$H$2:$H$1000,0),(MATCH("Ok",IF(NOT(INDEX(البيانات!$R$2:$AA$1000,MATCH(الخلاصة!$A2,البيانات!$H$2:$H$1000,0),)),"Ok"),0))-1) اذا لم تعمل معك المعادلة استبدل الفاصلة "," بفاصلة منقوطة ";" (حسب اعدادات الجهاز عندك ) لتصبح هكذا =INDEX(البيانات!$R$2:$AD$1000;MATCH(الخلاصة!A2;البيانات!$H$2:$H$1000;0);(MATCH("Ok";IF(NOT(INDEX(البيانات!$R$2:$AA$1000;MATCH(الخلاصة!$A2;البيانات!$H$2:$H$1000;0);));"Ok");0))-1)
  14. الصفوف الفارغه لا يتم ترحيلها الى الصفحة الثانية كي يتم حذفها
  15. أولاً -ما ذكرته في الرد على الاخ ياسر ابو البراءء: "وفي نفس الوقت لا اريد ان احذفها من الفاتورة الاصليه كي املئها مرة اخري بعد ذلك" لماذا تقم بتغيير رأيك ثانياً-لا احد يتشتري سمكاً في البحر ولا يمكن التخمين في هذا الامر ثالثاُ- ارفع ملفاً وهمياً عما تريد (فقط ثلاثة او اربع فواتير اي حوالي 20 سطر لا أريد الملف الاصلي فقط ملف مشابه ولا اريد صورة لانه لا يمكن التعامل مع الصور)
×