احمدزمان

السلام عليكم و رحمة الله وبركاته اخي الحنون ابو حنين جزاك الله كل خير على كلماتك الرقيقة اخي عمر جزاك الله خيرا اخي الفاضل الكريم ياسر الحافظ جزاك الله كل خير وحشتنه تعليقاتك و القابك الجميلة خالص تحياتي وتقديري اخي aspiran جزاك الله خيرا ===================== اخواني بسبب هذه الخاصية لقد استغنيت تماما عن الفورمز في ملفات الإكسل

السلام عليكم و رحمة الله وبركاته اخواني الكرام hassan.omar و shohb جزاكم الله كل خير على مروركم الكريم

السلام عليكم و رحمة الله وبركاته بعداذن اخي الحنون ابو حنين اخي عمر لم تجرب تجميد الألواح ====================== ومن ناحية اخرى قد يكون المطلوب في المرفق وعمله بالطريقة التالية حدد الخلايا التي تريد ان يمر عليها المؤشر بدون غيرها اختاار تنسيق الخلايا ومنه اختار حماية ثم الغاء تمكين الحماية ثم ضع الكود التالي Sub Macro1() ActiveSheet.Protect ActiveSheet.EnableSelection = xlUnlockedCells End Sub سوف يتم التنقل بين الخلايا الغير مؤمنة فقط في المرفق يتم التنقل بين الخلايا الصفراء فقط و الله اعلم تحديد نطاق تحرك المؤشر.rar

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

السلام عليكم اخي حمدي تم عمل المطلوب بدون فراغات لكن اصبحت الدالة طويلة قائمة منسدلةAZ.rar

السلام عليكم و رحمة الله وبركاته اخي خالد القدس الله يسلمك وجزاك الله خيرا على مرورك الكريم ========================= اخي حمدي الحمد لله انك وصلت لماتريد وموضوع الأسطر الفارغة سوف احاول فيه ========================= اخي SEEDHANY جزاك الله خيرا على مرورك الكريم

قد يكون هذا المطلوب قائمة منسدلةAZ.rar

السلام عليكم و رحمة الله وبركاته لم افهم ايه المطلوب

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

السلام عليكم و رحمة الله وبركاته اخواني ابوحنين و حمادة عمر شكرا لكم على كريم مروركما جزاكم الله كل خير

جزاك الله كل خير ابوحنين الله لايحرمك من حنين ولا يحرمنا من حنيتك

وايضا قم باضافة السطر التالي في اول الكويد Selection.QueryTable.Refresh BackgroundQuery:=False حيث سوف يقوم الزر بالتحديث و اضافة اسماء المطلوبة آمل ان يفي هذا بالغرض

السلام عليكم و رحمة الله وبركاته اخي الفاضل في هذه الحالة استخدم الكود القديم مع زر في نفس الورقة

print all_AZ.rar

Sub PRINT_ALL() Dim I As Integer For I = 6 To Sheets("AAA").Range("A" & Rows.Count).End(xlUp).Row w = Sheets("AAA").Cells(I, 1).Value [B5] = w Calculate If Sheets("BBB").Range("B7") = 10 Then GoTo 9 ActiveWindow.SelectedSheets.PrintOut Copies:=1 9 Next I End Sub السلام عليكم و رحمة الله وبركاته بالإضافة الى حل اخي HOORPIE الجميل هذا حل آخر بالتعديل على نفس كود اخونا الحبيب والقريب الى قلوبنا ابو احمد

Test02.rar

السلام عليكم يتم التغيير او البحث بمجرد الكتابه في العمود1 الى هوة A ويتم التعامل مع الصف الحالي فقط Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 1 Then Exit Sub Application.ScreenUpdating = False Dim FS As Worksheet, TS As Worksheet Dim FR, TR, ER1, ER2, Q1, Q2 Set FS = Sheets("Symbol") ' ?? ???E Set TS = Sheets(ActiveSheet.Name) ' C?? ???E ER1 = FS.UsedRange.Rows.Count ' ?II C????? Q2 = TS.Range("P1") ' C?? C???? TR = Target.Row Q1 = TS.Cells(TR, 1) ' C?? C?O??E For FR = 2 To ER1 If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then TS.Cells(TR, 15) = FS.Cells(FR, 3) GoTo 9 End If Next FR 9 Application.ScreenUpdating = True End Sub

وعليكم السلام و رحمة الله وبركاته فكرة رائعة جزاك الله خيرا

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

اخي ابو حنين سامحنا ابو حنين او ابو نصار كلكم عينين في راس

شكرا لكم على كريم مروركم و جزاكم الله كل خير

وعليكم السلام و رحمة الله وبركاته اخي الفاضل جرب الكود التالي Sub SYMBOOL() Dim FS As Worksheet, TS As Worksheet Dim FR, TR, ER1, ER2, Q1, Q2 Set FS = Sheets("Symbol") ' ãä æÑÞÉ Set TS = Sheets(ActiveSheet.Name) ' Çáì æÑÞÉ ER1 = FS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ ER2 = TS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ Q2 = TS.Range("P1") ' ÇÓã ÇáÓæÞ For TR = 2 To ER2 Q1 = TS.Cells(TR, 1) ' ÇÓã ÇáÔÑßÉ For FR = 2 To ER1 If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then TS.Cells(TR, 15) = FS.Cells(FR, 3) GoTo 9 End If Next FR 9 Next TR End Sub

وعليكم السلام و رحمة الله وبركاته اخي الفاضل جرب الكود التالي Sub SYMBOOL() Dim FS As Worksheet, TS As Worksheet Dim FR, TR, ER1, ER2, Q1, Q2 Set FS = Sheets("Symbol") ' ãä æÑÞÉ Set TS = Sheets(ActiveSheet.Name) ' Çáì æÑÞÉ ER1 = FS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ ER2 = TS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ Q2 = TS.Range("P1") ' ÇÓã ÇáÓæÞ For TR = 2 To ER2 Q1 = TS.Cells(TR, 1) ' ÇÓã ÇáÔÑßÉ For FR = 2 To ER1 If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then TS.Cells(TR, 15) = FS.Cells(FR, 3) GoTo 9 End If Next FR 9 Next TR End Sub

السلام عليكم و رحمة الله وبركاته كما ذكر رجل الأكواد الصعبة الأخ الحبيب ابو نصار يجب جلب البيانات الى نفس الملف و التعامل معها سواء بالكود او الدوال اذا كانت المشكلة في جلب البيانات اذا ممكن نستخدم خاصية جلب البيانات الخارجية الموجودة في الإكسل و الموجود في قائمة بيانات والذي يمثله الكود التالي Sub Macro1() Range("H8").Select With ActiveSheet.QueryTables.Add(Connection:= _ "TEXT;C:\Users\Aymz077\Desktop\test2.txt", Destination:=Range("$H$8")) .Name = "test2" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 720 .TextFileStartRow = 1 .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1) .TextFileFixedColumnWidths = Array(6, 6, 5) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With End Sub وهذا الكود يحتاج الى تعديل المسار و المجلد ومكان وضع البيانات تحياتي وتقديري

وعليكم السلام و رحمة الله وبركاته جزاك الله كل خير وجعله في ميزان حسناتك