سليم حاصبيا

يبدو ان هناك صفوفاً غير فارغة في الصفحة (فيها بيانات غير مرئية) قم بتحديد اكبر عدد من الصفوف ابتداء من الصف الثاني (حوالي 100 صف) واحذفها ثم نفذ الماكرو

بدل الى هذا الكود Private Sub CommandButton1_Click() Dim My_sh As Worksheet Set My_sh = Worksheets("ورقة1") Dim lastrow As Integer Dim i% With My_sh lastrow = .Cells(Rows.Count, 1).End(3).Row + 1 For i = 1 To 14 .Cells(lastrow, i).Value = Me.Controls("TextBox" & i) Me.Controls("TextBox" & i) = "" Next MsgBox "تم الترحيل" End With End Sub

بعد اذن الاخ علي المعادلة الموضوعة لا تعطي دائماً النتائج الصحيحية (مثلاً بالنسبة للرقم الاخير 155.656 نرى ان النتيجة 155.67 وليس 155.66 كما هو المطلوب) لذا اقترح هذه المعادلة =CEILING(B2,1/100)

جرب هذا الملف Aziz_salim.xlsx

لا ضرورة لغمل كود للطرح يكفي ان يضع عدداً سالباُ في الخلية D1

استعمل تنسيق الخلايا "yyyy"

حرب هذا الملف (لا ضرورة لتحميل الملف بالكامل اكثر من 3000 صف) يكفي 10 الى 20 صف في المرة المقبلة في الخلية هذه المعادلة واسحب نزولاً =SUMPRODUCT(--(A2&B2&C2&D2&E2=$A$2:A2&$B$2:B2&$C$2:C2&$D$2:D2&$E$2:E2)) 2018_salim.xlsx

.Select يعني تحديد (يكمن ان تحدد اكثر من شيء عدة أوراق نطاق بالكامل ....) Activate تنشيط (يعني من بين الخلايا أو الأوراق المحددة تنشيط الخلية او الورقة الثانية مثلاً) اذا كان المحدد شي واحد Select=Activate ربما يظهر الفرق اذا استعملت هذا الماكرو Option Explicit Sub Actv_SeL() Range("a1:a10").Select Range("a5").Activate End Sub Sub Actv_SeL_sheets() Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select Sheets("Sheet2").Activate End Sub

بعد اذن اخي علي لا ضرورة لهذا الكود الطويل يكفي هذا الكود Sub Auto_add() Range("d1").Copy Range("a2:a10").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Application.CutCopyMode = False Range("a2").Select End Sub الملف مرفق auto_add_Num.xlsm

جرب هذا الملف Opartion.xlsm

لحساب عدد ايام الحسم هذه المعادلة =QUOTIENT(G9,480) وعدد الدقائق =MOD(G9,480)

جرب هذا الملف مع اني في الاساس ضد لعبة دمج الخلايا ولا احبذها الكود Option Explicit Sub test() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim My_Rg As Range Dim r, x, i, m, k Dim st$ Set My_Rg = Range("a1").CurrentRegion.Columns(1) With Range("H:H") .UnMerge .ClearContents End With r = My_Rg.Rows.Count For i = 1 To r x = My_Rg.Cells(i).MergeArea.Rows.Count If x > 1 Then m = 1 For k = i To i + x - 1 st = st & Cells(i + m - 1, 2) & " " & Chr(10) m = m + 1 Next With Range("H" & i) .Resize(x).Merge .Value = Mid(st, 1, Len(st) - 1) End With m = 1 st = vbNullString i = i + x - 1 Else Range("H" & i) = My_Rg.Cells(i).Offset(, 1) End If Next End Sub الملف مرفق Salim دمج الخلايا.xlsm

هذه المعادلة في F9 و اسحب نزولاً =MID(C9,1,FIND("/",C9)-1) أو هذه =REPLACE(C9,FIND("/",C9),50,"")

جرب هذا الملف Auto_date.xlsm

اذا كان عندك ComboBox في الشيت قم بادراج اسمه في الكود بدل اسم 1 ComboBox و نفس الشيء بالنسبة للـــ Button و اذا لم يكن عندك احذف هذا الماكرو

جرب هذه الملف الكود Sub filter_for_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("Details") Dim T_sh As Worksheet: Set T_sh = Sheets("Statement") Dim My_Table As Range: Set My_Table = S_sh.Range("A4").CurrentRegion With T_sh .Range("a10").CurrentRegion.ClearContents .Range("q2").Formula = _ "=AND(Details!B5>=$B$6,Details!B5<=$B$7,Details!C5=$B$5)" My_Table.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("Q1:Q2"), _ CopyToRange:=.Range("A10") .Range("q2").ClearContents .Columns("B:G").AutoFit End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق المصاريف.xlsm

ارسل صورة عن الخطأ داخل الماكرو للمعالجة أو ارسل نموذج عن الملف الذي تعمل عليه

تم التعديل Sader_Wared1.xlsm

شكراً على هذه الملاحظات القيمة و سأعمل على تحقيقها بالنسبة للملاحظة رقم 2 يحب وضع هذا الشرط لمنع المستخدم من الترحيل اكثر من مرة مثلا قام محمد بترحيل رسالة رقم 50 و نجح في ذلك ثم جاء موظف ثاني واراد ان يرحل نفس الرسالة رقم 50 (لعدم معرفته ان محمد قام بهذا الأمر) فهنا تقع المشكلة احيراً في حال تكرار رقم الوارد لرسالتين (من الحالات النادرة ) يمكن بكل بساطة زيادة مسافة فارغة على احد أرقام الرسالتين

عندي يعمل بشكل جيد (لا أعلم ما المشكلة عندك) ربما انت تكتب أنثى مع همزة او بدون (انثى) يجب الكتابة تماماً كما في الخلية الصفراء دون مسافات زائدة او ناقصة

اليك الحل _salimقائمة.xlsx

هذه المعادلة في G11 =IF(COUNTIF($E$11:E11,E11)>1,"",SUMPRODUCT(($A$2:$A$8=E11)*($B$2:$B$8)))

يسألونك دائماً عن ملف الصادر والوارد فكان هذا الملف الذي ارجو ان يستفيد منه اكبر عدد من المستخدمين فقط املأ الجدول بالبيانات اللازمة و حدد صفحة الترحيل واضغط على الزر من مميزاته: لا يسمح لك بتكرار رقم الصادر او الوارد لا يسمح لك بترحيل بيانات غير مكتملة Sader_Wared.xlsm

اثراءً للموضوع و بعد اذن اخي علي هذا الملف الكود Option Explicit Sub TransferData() Dim My_Sh As Worksheet, My_Rg As Range Dim My_row%, Rp%, i%, My_Match% Dim Ar1(1 To 2), Ar2(1 To 2) Ar1(1) = "Sader": Ar1(2) = "Wared" Ar2(1) = "صادر": Ar2(2) = "وارد" Dim Sh_Name$ Rp = Principal.Cells(Rows.Count, 2).End(3).Row If Rp <= 3 Then MsgBox "لا يوجد بيانات لنقلها", 1048640: GoTo Exit_Me Sh_Name = Application.Index(Ar1, Application.Match(Principal.Range("a2"), Ar2, 0)) Set My_Sh = Sheets(Sh_Name) My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row + 1 Set My_Rg = Principal.Range("b4:E" & Rp) For i = 1 To My_Rg.Rows.Count If Application.CountA(My_Rg.Cells(i, 1).Resize(1, 4)) < 4 Then MsgBox "هناك بيانات غير مكتملة في النطاق" & Chr(10) & _ My_Rg.Cells(i, 1).Resize(1, 4).Address & Chr(10) _ & "لا يمكن الترحيل", 1048640 GoTo Exit_Me End If Next '========================================== For i = 1 To My_Rg.Rows.Count On Error Resume Next My_Match = Application.Match(My_Rg.Cells(i, 1), My_Sh.Range("a:a"), 0) If My_Match Then MsgBox "There Are Duplicates" & Chr(10) & My_Rg.Cells(i, 1) & _ " is Already existe in Sheet: " & My_Sh.Name: GoTo Exit_Me: On Error GoTo 0 Next '======================================= For i = 1 To My_Rg.Rows.Count My_Sh.Range("a" & My_row).Resize(My_Rg.Rows.Count, 4).Value = My_Rg.Value My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row Principal.Range("b2") = My_Sh.Range("a" & My_row) Next My_Rg.ClearContents Exit_Me: Erase Ar1: Erase Ar2: Set My_Rg = Nothing: Set My_Sh = Nothing On Error GoTo 0 End Sub الملف Sader_Wared.xlsm

لم افهم ماذا تعني بــــ يجب ان يتساوى ارقام العمودين حمل جدول بالنتائج المتوقعة