logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
بكار للأبد لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة خطأ برمجي والماكرو لا يعمل run time error 438 اكسيل اسئله واجابات



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





19-06-2020 06:40 مساءً
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس :
تاريخ الميلاد : 17-8-1981
قوة السمعة : 244
الاعجاب : 0
السلام عليكم
لدي هذا الكود يعمل جيدا لكن المشكلة انه يجب ان تكون القيم مطابقة في جميع الاعمدة في كل الشيتات حيث لا يتم جلب البيانات في الشيت الاخير اذاكان احد الاعمدة مختلف عن الاخر بمعنى اا كانت في العمود a في الشيت 1 ff وغير موجودة في الشيت الثاني للعمود b وغير موجودة في الشيت الثالث في العمود c لن يجلب البيانات
CODE
Sub Test()
Dim Temp(), i As Long, Fnd As Range, ws As Worksheet
ReDim Temp(1 To Sheets.Count - 1, 1 To 3)
For Each ws In ThisWorkbook.Sheets
    If Not ws.Name = "result" Then
        With ws
            Set Fnd = .UsedRange.Find(sheet4.Range("A2"), , xlValues, xlWhole)
            If Not Fnd Is Nothing Then
                i = i + 1: Temp(i, 1) = .Name: Temp(i, 2) = Fnd.Address: Temp(i, 3) = sheet4.Range("A2")
            End If
        End With
    End If
Next ws
If Fnd Is Nothing Then
    MsgBox "NO MATCHES"
Else
    sheet4.Range("A6").Resize(i, 3) = Temp
End If
End Sub
 
 
  SHEET1 ‫‬.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(17.971) KB





look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  19-06-2020 07:34 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
جرب هذا الكود
CODE

Option Explicit
Sub Test()
Dim R As Worksheet, ws As Worksheet
Dim k%
Dim Fnd As Range
k = 6
Set R = Sheets("result")
    If R.Range("A5").CurrentRegion.Rows.Count > 1 Then
       R.Range("A5").CurrentRegion.Offset(1). _
       Resize(R.Range("A5").CurrentRegion. _
       Rows.Count - 1).ClearContents
    End If
    
    If R.Range("A2") = vbNullString Then
    MsgBox "Type in cell A2 a value to find it"
    Exit Sub
    End If
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = R.Name Then
   With ws
    Set Fnd = .UsedRange.Find(R.Range("A2"), lookat:=1)
       If Not Fnd Is Nothing Then
            With R.Cells(k, 1)
                .Value = ws.Name
                .Offset(, 1) = Fnd.Address
                .Offset(, 2) = Fnd
               k = k + 1
             End With
        End If
   End With
End If
Next ws
If k = 6 Then MsgBox "I Can't Find  " & _
 """" & R.Range("A2") & """" & "  Any Where"
End Sub



الملف مرفق
 
 
  Moubtadaa.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(29.232) KB


أثارت هذه المشاركة إعجاب: المبتدأ،



look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  19-06-2020 07:43 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس :
تاريخ الميلاد : 17-8-1981
قوة السمعة : 244
الاعجاب : 0
شكرا استاد سليم لو امكن اضافة رسالة تحذير بمعنى لو كتبت احرف صغيرة يظهر لي رسالة تحذيرية بعدم وجود هذا الصنف اي البحث خاص بالاحرف الكبيرة فقط




look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  19-06-2020 09:36 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10522
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36735
الاعجاب : 177
أخي الكريم
هل أصبح التعديل على الأكواد أو المحاولة مستحيل حتى لا تتمكن من وضع رسالة ...؟!! أعتقد لابد من معرفة الأساسيات بشكل جيد .. فالمنتدى تعليمي وليس خدمي

أثارت هذه المشاركة إعجاب: الصقر،



look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  19-06-2020 10:32 مساءً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس :
تاريخ الميلاد : 17-8-1981
قوة السمعة : 244
الاعجاب : 0
استاد ياسر اشكرك على المرور ولكن لو ان الشخص غير متخصص بالبرمجة ماذا يفعل ثم ان جل المواقع عندما يعطيك كود ليس مستعد صاحب الكود ان يشرح ه لك سطر سطر حتى موقعكم الكريم بالكاد يجيب بشكل عام ولا يتناول بعض الخصائص التي يصعب على غير المبرمج فهمها




look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  19-06-2020 10:38 مساءً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10522
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36735
الاعجاب : 177
أخي الكريم
المنتدى مليء بالموضوعات والشروحات ، يبدو أنك لم تتصفح الموقع بشكل جيد
والحلول التي تقدم بالكاد ، ستجد أفضل منها في مواقع أخرى ، وخصوصاً المواقع الأجنبية ..
وفقك الله




look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  20-06-2020 08:12 صباحاً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
تم التعديل على الكود ( Case Sinsitive )
ليتناسب مه ما تريد
بالاضافة الى أنه اذا ظهر ما نبحث عنه أكثر من مرة في نفس الشيت يتم ادراجه ايضاً
 
 
  Moubtadaa-1.xlsm   تحميل xlsm مرات التحميل :(6)
الحجم :(33.271) KB


أثارت هذه المشاركة إعجاب: المبتدأ، omhamzh، YasserKhalil، abouelhassan،



look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  20-06-2020 08:22 صباحاً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس :
تاريخ الميلاد : 17-8-1981
قوة السمعة : 244
الاعجاب : 0
شكرا استاد سليم على هذا الكود الرائع




look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  20-06-2020 08:40 صباحاً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
و هذا أجمل (مجرد تطوير لا أكثر)
CODE

Option Explicit
Sub New_Test()
Dim R As Worksheet, ws As Worksheet
Dim k%, Adr1$, Adr2$
Dim Fnd As Range, mot
Dim arr(), t%, St$
k = 6

Set R = Sheets("result")
mot = R.Range("A2")
    If R.Range("A5").CurrentRegion.Rows.Count > 1 Then
       R.Range("A5").CurrentRegion.Offset(1). _
       Resize(R.Range("A5").CurrentRegion. _
       Rows.Count - 1).ClearContents
    End If
    
    If mot = vbNullString Then
      MsgBox "Type in cell A2 a value to find it"
      Exit Sub
    End If
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = R.Name Then
   With ws
        Set Fnd = .UsedRange.Find(mot, lookat:=1)
          If Fnd Is Nothing Then GoTo Next_sheet
           
            Adr1 = Fnd.Address: Adr2 = Adr1
          Do
            If mot <> Fnd Then
             ReDim Preserve arr(t)
              arr(t) = ws.Name & " : " & Fnd.Address
              t = t + 1
            End If
            
              If mot = Fnd Then
                 With R.Cells(k, 1)
                     .Value = ws.Name
                     .Offset(, 1) = Adr2
                     .Offset(, 2) = Fnd
                    k = k + 1
                  End With
              End If
               Set Fnd = .UsedRange.FindNext(Fnd)
               Adr2 = Fnd.Address
              If Adr2 = Adr1 Then Exit Do
          
          Loop
   End With
End If

Next_sheet:
Next ws
If k = 6 Then MsgBox "I Can't Find  " & _
 """" & R.Range("A2") & """" & "  Any Where"
 If t > 0 Then
   For k = 0 To UBound(arr)
      St = St & arr(k) & Chr(10)
   Next
    St = "Case Insensitive in :" & Chr(10) & St
    MsgBox St
 End If
End Sub


الملف بعد تحديثه
 
 
  Moubtadaa-2.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(34.521) KB


أثارت هذه المشاركة إعجاب: المبتدأ، YasserKhalil، ali mohamed ali، abouelhassan،



look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  20-06-2020 09:29 صباحاً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس :
تاريخ الميلاد : 17-8-1981
قوة السمعة : 244
الاعجاب : 0
فعلا الاجمل بينهم شكرا على مجهوداتك الرائعة

أثارت هذه المشاركة إعجاب: salim،



look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  20-06-2020 09:59 صباحاً   [10]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10522
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36735
الاعجاب : 177
بارك الله فيك أخي العزيز سليم وجزاك الله خيراً

أثارت هذه المشاركة إعجاب: salim،



look/images/icons/i1.gif تعديل كود جلب اسماء الشيتات وعناوين الخلايا
  20-06-2020 04:38 مساءً   [11]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-05-2020
رقم العضوية : 19295
المشاركات : 184
الجنس :
قوة السمعة : 423
الاعجاب : 3
شكر وتقدير واحترام استاذنا الفاضل

أثارت هذه المشاركة إعجاب: YasserKhalil، salim،



اضافة رد جديد اضافة موضوع جديد



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
طلب كود نسخ شيت بالتنسيق مع تغير اسماء الشيتات عن طريق عمود مكتوب فيه الاسماء الجديدة abouelhassan
4 977 YasserKhalil
كود تغير اسماء الشيتات omhamzh
3 684 YasserKhalil
تلوين اسماء الشيتات بضغطة واحدة لاى عدد من الشيتات مجدى يونس
5 1648 مجدى يونس

الكلمات الدلالية
الخلايا ، وعناوين ، الشيتات ، اسماء ، تعديل ،









اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 09:42 AM