أبو حنــــين

استعمل هذا التغيير Private Sub Workbook_Open() Dim M, pasword pasword = "1234" If Date > #1/1/2015# Then M = MsgBox("ان كانت لديك كلمة المرور فاضغظ على نعم", vbCritical + vbYesNo, "تأكيد") If M = vbNo Then Application.Quit Else If M = vbYes Then If pasword = InputBox("ادخل كلمة المرور هنا", "كلمة المرور") Then ورقة1.Select Exit Sub GoTo 1 Else MsgBox "ليس لديك الحق لفتح البرنامج", vbCritical, "خطأ" Application.Quit End If: End If: End If: End If 1 End Sub

أخي : أبو سما جزاكم الله خيرا على المرور حفظكم الله ورعاكم

و اذا اردت نقل الاسماء الى الجدول دون اخفاء هذا الكود لنقل الاسماء التي تحتوي على ارقام Sub Macro2() r = 5 For Each cl In Sheets("Feuil1").Range("D5:D20") If IsNumeric(Right(cl, 1)) Then cl.Resize(, 1).Copy Range("F" & r) r = r + 1 End If Next End Sub و هذا الكود لنقل الاسماء التي لا تحتوي على ارقام Sub Macro3() r = 5 For Each cl In Sheets("Feuil1").Range("D5:D20") If Not IsNumeric(Right(cl, 1)) Then cl.Resize(, 1).Copy Range("F" & r) r = r + 1 End If Next End Sub

يمكن استعمال الكود التالي Sub Macro1() For Each cl In Sheets("Feuil1").Range("D5:D20") If IsNumeric(Right(cl, 1)) Then _ cl.EntireRow.Hidden = True Next End Sub

السلام عليكم جزاك الله خيرا أخي ضاحي الغريب على هذا العمل و هذا السلوك الطيب أثابكم الله و جعله في ميزان حسناتكم

السلام عليكم استعمل هذا الكود Private Sub CommandButton3_Click() If ListBox1.ListCount = 0 Then Exit Sub Dim NBook As Workbook Set NBook = Workbooks.Add With NBook .Sheets(1).Range("A1:I1") = ورقة1.Range("A1:I1").Value .Sheets(1).Range("A2").Resize(ListBox1.ListCount, 9).Value = ListBox1.List .SaveAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "dd") .Close End With End Sub حيث يتم حفظ الملف في نفس مسار الملف الاصلي و يحمل اسم اليوم مثلا 09 او 08 و هكذا

شاهد المرفق فهو يعمل كما طلب الملف.rar

جزاك الله خيرا اخي : zmzm اما جديدنا فهو القديم و قديمنا يتطلب التجديد

جزاك الله خيرا فعلا هذا موضوع مهم للغاية و سيستفيد منه الكثيرون

السلام عليكم اخي هل تريد منع التعديل او السماح بالتعديل على البيانات المستوردة ان كنت تريد التعديل عليها فما الفائدة من حمايتها

السلام عليكم سعدت كثيرا بحكمة اخي جمال في مثل هذه المواقف و ذلك لإلتزامه بالصمت و سعدت أكثر بأخي محمد عبارة لتداركه زلة اللسان في لحظة انفعال هكذا هي اخلاقنا ليس الشديد بالصرعة، إنما الشديد الذي يملك نفسه عند الغضب و خير الخطائين التوابون و السلام عليكم

جزاك الله خيرا أخي محمد 28

شاهد المرفق 2003 مثال.rar

السلام عليكم ثم عمل المطلوب لكن مشكلة السكانير لا اعرف ما هو السبب في ذلك الملف الثاني هو فيديو يوضح طريقة عمل ايقونة للبرنامج الصادر و الوار$-2.rar الايقونة.rar

جرب هذا التغيير Sub ReadTextFile() ActiveSheet.Unprotect Password:=123 Dim fs As Object ' scripting.filesystemobject Dim txtIn As Object ' scripting.textstream Dim strFile As String 'File Name Dim strLine As String 'Current line being read. Dim iRow As Integer Range("A6:E29").Clear Set fs = CreateObject("scripting.FileSystemObject") iRow = 6 strFile = "c:\DATAP.txt" Set txtIn = fs.openTextFile(strFile, 1) ' 1 ForReading Do While Not txtIn.AtEndOfStream Cells(iRow, 1) = txtIn.ReadLine iRow = iRow + 1 Loop Range("A1").EntireColumn.TextToColumns Tab:=True ActiveSheet.Cells.Locked = False ActiveSheet.UsedRange.Cells.Locked = True ActiveSheet.Protect Password:=123 End Sub

في بداية الكود أكتب السطر ActiveSheet.Unprotect Password = "123" و ذلك لفك الحماية و في نهاية الكود أكتب السطر ActiveSheet.Protect Password = "123" و ذلك للحماية من جديد حيث 123 هي كلمة الحماية المختارة

السلام عليكم ارسل مثالا توضح فيه المطلوب لارسال ملف يجب ضغطه اولا ثم رفعه الى المنتدى

السلام عليكم جرب هذا Private Sub Worksheet_Change(ByVal Target As Range) Dim MyRange As Range If Target.Address = "$D$42" Then ActiveSheet.Name = Left(Target.Value, 10) Set MyRange = Union([J5:J27], [L10:P27], [P40:P44]) If Intersect(Target, MyRange) Is Nothing Then Exit Sub Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each Ce In MyRange If IsNumeric(Ce) = False Then GoTo 1 With Ce .NumberFormat = "_(#,##0.00_);[Red]_((#,##0.00);_(--_);_(@_)" If .Value = 0 Then .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter Else .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End If End With 1 Next Ce Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

السلام عليكم جرب المرفق و لا ادري ان كانت هناك اخطاء او لا الصادر و الوارد_.rar

أخي قنديل الصياد قبل ان اتصفح الكتاب و قبل ان يتم التحميل جزاك الله خيرا على هذا المجهود

السلام عليكم أخي أبو مهند الخضري سأرى قريبا كل ملاحظاتك ان شاء الله ***************************************************** أخي أحمد ريان يمكن عمل ذلك لكن بتغيير في الكود ***************************************************** أخي يوسف السيد جزاكم الله خيرا على المرور *****************************************************

السلام عليكم بالكود يكون الحل كالتالي : Sub Duplicata() Dim i As Long, Last As Long With Sheets("بيانات غير متكررة") .Range("A2:Q" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents End With Set MySheet = Sheets("الاساسى") With MySheet Last = .Cells(Rows.Count, "B").End(xlUp).Row + 1 x = 2 Application.ScreenUpdating = False For i = .Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1 If WorksheetFunction.CountIf(.Range("B2:B" & i), .Range("B" & i).Value) = 1 Then .Range("A" & i).Resize(1, 17).Copy Sheets("بيانات غير متكررة").Range("A" & x).PasteSpecial Paste:=xlPasteValues x = x + 1 End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End With End Sub

السلام عليكم اخي احمد النجار جزاكم الله خيرا على هدا الموضوع المهم

هناك استدارك في الملف Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = True End Sub برنامج الصادر والوارد_2.rar

السلام عليكم اضافة لما قدمه اخي شوقي ربيع هذه مبادرة اخرى برنامج الصادر والوارد_1.rar