عبدالسلام ابوالعوافي

جرب =TEXT(B2;"@")&" "&TEXT(F2;REPT("0";LEN(F2)))&" "&TEXT(B3;"@")

اكتب في مربع الاسم A1:C12000

يمكنك الاستعانة بخلية في الملف ويكون الكود كالاتي Sub Once() If Sheet1.Cells(1, 1) = Date Then Exit Sub 'your code Sheet1.Cells(1, 1) = Date End Sub

لو فواصل الصفحة اتوماتيكية لن تحدث هذه المشكلة .. بمعنى لو فواصل الصفحات خطوط متقطعة سيتم تحديد الصفحات تلقائيا . وفي هذا الملف الفواصل خطوط متصلة اي بمعنى انها من تنسيقك وانت من حدد الصفوف في كل صفحة

قائمة الاسماء.xlsx

جرب معادلة صفيف =IFNA(INDEX($H$2:$H$9;MATCH(1;--(A2=$H$2:$H$9);0));"") قائمة الاسماء.xlsx

طريقة اخرى =IFNA(INDIRECT("b"&MATCH(1;(--({3,4,5,6}=A1))+(--({9,10,11,12}=A1));0));"")

استخدم Error Handling

جرب الملف المرفق الطريقة هي ان تحدد الخلايا التي تحتوي علي ارقام وتريد اجراء عمليات حسابية عليها ثم شغل الكود المرفق التجربة في الملف وقارن بين الشيتين Sub test() Dim cll As Range Dim i As String Dim ii As Double For Each cll In Selection If Len(cll) > 1 Then i = Len(cll) ii = CDbl(Right(Left(cll, i - 1), i - 2)) cll = ii End If Next End Sub baj 04-2017 -Acc#003 - Copy 2.rar

لو تم رفع الملف لكان الاجابة اسهل واوضح .. لكن فكرة العمل كالاتي TextBox1 = Right("0" & Key, 2) حيث key هو رقم المفتاح

بعد اذن الاستاذ ياسر .. توجد طريقة اخرى بدون دالة IF بفرض العمودين A و B نكتب في العمود C الاتي =--(B1=A1)

وعليكم السلام من عيوب الاكسل البطئ عندما تكون البيانات كبيرة .. ومن الطرق المفيدة في هذه الحالة هي استخدام لغة سيكول اليك الكود الاتي ليقوم بالترحيل بسرعة اكبر من المعادلات .. المثال في المرفق ملاحظة .. تمت التجربة علي اوفس 2013 وقد يحتاج الي تعديل مع النسخ الاخري Sub InQuery() Dim intLastR As Double Dim strSQL Dim Conn As New ADODB.Connection Dim rs As New ADODB.Recordset Dim srtPath As String, strConn As String With Application .ScreenUpdating = False .DisplayStatusBar = False .Calculation = xlCalculationManual .EnableEvents = False End With intLastR = ActiveSheet.UsedRange.Rows.Count Sheets("Sheet2").Columns(1).ClearContents srtPath = ThisWorkbook.FullName strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & srtPath & ";" & _ "Extended Properties=""Excel 12.0 Macro;HDR=Yes;IMEX=1"";" intLastR = Sheets("Sheet1").UsedRange.Rows.Count Conn.Open strConn strSQL = "SELECT * From [Sheet1$A1:b" & intLastR & "] WHERE [Column1] = 1" Debug.Print strSQL Debug.Print Conn rs.Open strSQL, Conn Sheet2.Range("A2").CopyFromRecordset rs Sheet2.Columns(2).ClearContents rs.Close Conn.Close With Application .ScreenUpdating = True .DisplayStatusBar = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub ارقام.rar

بعد اذن الاستاذ ياسر .. جرب هذا الكود Sub anwar_abo_malik_Sum() For i = 1 To 6 LstRow1 = Cells(Rows.Count, i).End(xlDown).Row Cells(LstRow1, i).Value = "" With Range(Cells(4, i), Cells(LstRow1, i)) .Font.Bold = False .Interior.ColorIndex = 0 End With X = Application.WorksheetFunction.Sum(Range(Cells(4, i), Cells(LstRow1, i))) Cells(1, i) = X With Cells(1, i) .Interior.ColorIndex = 8 .Font.Bold = True End With Next End Sub

ربما يكون المطلوب بالمرفق ZAT1.rar

وعليكم السلام .. تنسيق شرطي كما في المرفق تنسيق شرطي.rar

السلام عليكم . بعد اذن اخي خالد .. جرب هذا الملف Book213.rar

وعليكم السلام لما لا تستخدم Find And Replace بالضغط علي Ctrl + H وتكتب عبد لاستبدالها بعبد مضاف اليها مسافة ثم تستبدل المسافتين بمسافة

غير طريقة العرض كما في الصورة

نال اعجابنا

لعله يفيد إدارة وأقسام.rar إدارة وأقسام.rar

الكود اعلاه يقف علي اول خلية فارغة وكنت اعتقد هذا الاصوب .. جرب الكود الاتي لعله يفي بالغرض Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim i As Integer Dim ii As Integer ii = 0 For i = 9 To 19: If Cells(i, "L") = "" Then ii = i Next i For i = 28 To 34: If Cells(i, "L") = "" Then ii = i Next i i = 36: If Cells(i, "L") = "" Then ii = i If ii > 0 Then GoTo a ActiveWindow.SelectedSheets.PrintOut Copies:=1 ', Preview:=True Exit Sub a: MsgBox "عذرا لن تتم الطباعة لوجود خانات فارغة يجب أن تعبأ": Cancel = True: Cells(ii, "L").Select End Sub

جرب Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim i As Integer For i = 9 To 19: If Cells(i, "L") = "" Then GoTo a Next i For i = 28 To 34: If Cells(i, "L") = "" Then GoTo a Next i i = 36: If Cells(i, "L") = "" Then GoTo a ActiveWindow.SelectedSheets.PrintOut Copies:=1 ', Preview:=True Exit Sub a: MsgBox "عذرا لن تتم الطباعة لوجود خانات فارغة يجب أن تعبأ": Cancel = True: Cells(i, "L").Select End Sub

كود يقوم باخفاء الاعمدة A:N اذا كانت الخلايا في الصف الثاني تساوي صفر قم بتعديله بما يناسبك Sub HideClms() Dim i As Integer Columns("A:N").Hidden = False For i = 1 To 15 If Cells(2, i) = 0 Then Columns(i).EntireColumn.Hidden = True Next End Sub

الف الف مبروك اخي سليم .. ترقية مستحقة بجدارة وفي محلها .. اتمنى لك التوفيق

بارك الله فيك استاذنا .. لك اكثر والله وكل عام وانت بخير ماشاء الله عليك .. نشاط كبير كالعادة .. مااستطع الاجابة علي الاسئلة قبلك .. كانت اجابتي من باب المشاركة فقط . وفقك الله استاذنا الحبيب