Note: The other languages of the website are Google-translated. Back to English

كيفية مزامنة القوائم المنسدلة في أوراق عمل متعددة في إكسيل؟

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

مزامنة القوائم المنسدلة في أوراق عمل متعددة باستخدام كود VBA


مزامنة القوائم المنسدلة في أوراق عمل متعددة باستخدام كود VBA

على سبيل المثال ، القوائم المنسدلة موجودة في خمس أوراق عمل مسماة ورقة 1 ، ورقة 2 ، ...، ورقة 5 ، لمزامنة القوائم المنسدلة في أوراق العمل الأخرى وفقًا للاختيار المنسدل في الورقة 1 ، يرجى تطبيق رمز VBA التالي لإنجازه.

1. افتح الورقة 1 ، وانقر بزر الماوس الأيمن فوق علامة تبويب الورقة وحدد عرض الرمز من قائمة النقر بزر الماوس الأيمن.

2. في ال ميكروسوفت فيسوال باسيك للتطبيقات في النافذة ، قم بلصق رمز VBA التالي في ملف الورقة 1 (الرمز) نافذة.

كود فبا: مزامنة القائمة المنسدلة في أوراق عمل متعددة

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220815
    Dim tSheet1 As Worksheet
    Dim tRange As Range
    Dim xRangeStr As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr = "A2:A11"

    Set tRange = Intersect(Target, Range(xRangeStr))
    If Not tRange Is Nothing Then
        xRangeStr = tRange.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet2")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet3")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet4")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet5")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Application.EnableEvents = True
    End If
    
End Sub

الملاحظات:

1) في الكود ، A2: A11 هو النطاق الذي يحتوي على القائمة المنسدلة. تأكد من أن جميع القوائم المنسدلة موجودة في نفس النطاق عبر أوراق عمل مختلفة.
2) ورقة 2 ، ورقة 3 ، ورقة 4 و Sheet5 هي أوراق عمل تحتوي على قوائم منسدلة تريد مزامنتها استنادًا إلى القائمة المنسدلة في الورقة 1 ؛
3) لإضافة المزيد من أوراق العمل في الكود ، يرجى إضافة السطرين التاليين قبل السطر "Application.EnableEvents = صحيح"، ثم قم بتغيير اسم الورقة"Sheet5"إلى الاسم الذي تحتاجه.
اضبط tSheet1 = ActiveWorkbook.Worksheets ("Sheet5")
tSheet1.Range (xRangeStr) .Value = Target.Value

3. اضغط على قديم + Q مفاتيح لإغلاق ميكروسوفت فيسوال باسيك للتطبيقات نافذة.

من الآن فصاعدًا ، عند تحديد عنصر من القائمة المنسدلة في ورقة 1 ، ستتم مزامنة القوائم المنسدلة في أوراق العمل المحددة تلقائيًا للحصول على نفس التحديد. انظر أدناه التجريبي.


عرض توضيحي: مزامنة القوائم المنسدلة في أوراق عمل متعددة في Excel


أفضل أدوات إنتاجية المكتب

Kutools for Excel يحل معظم مشاكلك ويزيد إنتاجيتك بنسبة 80٪

  • إعادة استخدام: أدخل بسرعة الصيغ المعقدة والرسوم البيانية وأي شيء استخدمته من قبل ؛ تشفير الخلايا مع كلمة السر إنشاء قائمة بريدية وإرسال رسائل البريد الإلكتروني ...
  • سوبر فورميولا بار (بسهولة تحرير أسطر متعددة من النص والصيغة) ؛ تخطيط القراءة (قراءة وتحرير أعداد كبيرة من الخلايا بسهولة) ؛ لصق في النطاق المصفى
  • دمج الخلايا / الصفوف / الأعمدة دون فقدان البيانات ؛ تقسيم محتوى الخلايا ؛ ادمج الصفوف / الأعمدة المكررة... منع تكرار الخلايا؛ قارن النطاقات
  • حدد مكرر أو فريد صفوف حدد صفوف فارغة (جميع الخلايا فارغة) ؛ البحث الفائق والبحث الغامض في العديد من المصنفات. تحديد عشوائي ...
  • نسخة طبق الأصل خلايا متعددة بدون تغيير مرجع الصيغة ؛ إنشاء المراجع تلقائيًا إلى أوراق متعددة أدخل الرموز النقطية، مربعات الاختيار والمزيد ...
  • استخراج النص، إضافة نص ، إزالة حسب الموضع ، إزالة الفضاء؛ إنشاء وطباعة المجاميع الفرعية لترحيل الصفحات ؛ التحويل بين محتوى الخلايا والتعليقات
  • سوبر تصفية (حفظ وتطبيق مخططات التصفية على أوراق أخرى) ؛ فرز متقدم حسب الشهر / الأسبوع / اليوم ، التكرار والمزيد ؛ مرشح خاص بواسطة bold، italic ...
  • اجمع بين المصنفات وأوراق العمل؛ دمج الجداول على أساس الأعمدة الرئيسية ؛ تقسيم البيانات إلى أوراق متعددة; تحويل دفعة xls و xlsx و PDF
  • أكثر من 300 ميزة قوية. يدعم Office / Excel 2007-2021 و 365. يدعم جميع اللغات. سهولة النشر في مؤسستك أو مؤسستك. الميزات الكاملة نسخة تجريبية مجانية لمدة 30 يومًا. ضمان استرداد الأموال لمدة 60 يومًا.
علامة تبويب kte 201905

يجلب Office Tab الواجهة المبوبة إلى Office ، ويجعل عملك أسهل بكثير

  • تمكين التحرير والقراءة المبوبة في Word و Excel و PowerPointوالناشر والوصول و Visio والمشروع.
  • فتح وإنشاء مستندات متعددة في علامات تبويب جديدة من نفس النافذة ، بدلاً من النوافذ الجديدة.
  • يزيد من إنتاجيتك بنسبة 50٪ ، ويقلل مئات النقرات بالماوس كل يوم!
أوفيسيتاب القاع
فرز التعليقات حسب
التعليقات (5)
لا يوجد تقييم. كن أول من يقيم!
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا،

كيف يمكنني القيام بذلك إذا كانت القوائم المنسدلة في نطاقات مختلفة؟ للتوضيح ، لدي قائمة منسدلة في الورقة 7 الموجودة في الخلية B7 ونفس القائمة المنسدلة في الورقة 6 في الخلية B2.

شكرا لكم,
إلين
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا E ،
يمكن أن يساعد رمز VBA التالي.
هنا آخذ ورقة 6 باعتبارها ورقة العمل الرئيسية ، انقر بزر الماوس الأيمن فوق علامة تبويب الورقة ، وحدد عرض الرمز من قائمة النقر بزر الماوس الأيمن ، ثم انسخ الكود التالي في نافذة الورقة 6 (الرمز). عند تحديد أي عنصر من القائمة المنسدلة في B2 من الورقة 6 ، سيتم مزامنة القائمة المنسدلة في B7 من الورقة 7 للحصول على نفس العنصر المحدد.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221025
    Dim tSheet1 As Worksheet
    Dim tRange As Range
    Dim xRangeStr As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr = "B2"
    
    Set tRange = Range("B7")
    If Not tRange Is Nothing Then
        xRangeStr = tRange.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Application.EnableEvents = True
    End If
    
End Sub
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبا كريستال ،

شكرا جزيلا لردك ، لقد نجحت التعليمات البرمجية الخاصة بك! لدي خلية أسفل b2 و b7 و b3 و b8 على التوالي والتي تحتاج إلى نفس الوظيفة. حاولت إعادة كتابة الكود الخاص بك كما هو موضح أدناه ، لكن هذا لم ينجح. لقد تسبب في تغيير b7 بدلاً من b8 عندما قمت بتغيير b3. هل يمكن أن تكون قادرًا على تحديد الخطأ الذي أفعله؟

شكرا جزيلا!

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221025
    Dim tSheet1 As Worksheet
    Dim tRange1 As Range
    Dime tRange2 As Range
    Dim xRangeStr1 As String
    Dim xRangeStr2 As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr1 = "B2"
    xRangeStr2="B3"
    
    Set tRange1 = Range("B7")
    If Not tRange1 Is Nothing Then
        xRangeStr1 = tRange1.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr1).Value = Target.Value
        Application.EnableEvents = True
    End If
    
    Set tRange2 = Range("B8")
    If Not tRange2 Is Nothing Then
        xRangeStr2 = tRange2.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr2).Value = Target.Value
        Application.EnableEvents = True
    End If

End Sub
تم تصغير هذا التعليق بواسطة المشرف على الموقع
مرحبًا E ،
هناك خطأ ما في رمز VBA الذي أجبته عليك أعلاه.
بالنسبة للسؤال الجديد الذي ذكرته ، يرجى تجربة الكود التالي.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221031
    
    Dim xBool1 As Boolean
    Dim xBool2 As Boolean
    Dim xRgStr As String
    Dim tRange As Range
    
    xRangeStr1 = "B2"
    xRangeStr2 = "B3"
    xRgStr = ""
    
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    xBool1 = Intersect(Target, Range(xRangeStr1)) Is Nothing
    xBool2 = Intersect(Target, Range(xRangeStr2)) Is Nothing
    
    If xBool1 And xBool2 Then Exit Sub
    
    xRgStr = Target.Address(False, False, xlA1, False, False)
    
    If Target.Address(False, False, xlA1, False, False) = xRangeStr1 Then
        xRgStr = "b7"
    ElseIf Target.Address(False, False, xlA1, False, False) = xRangeStr2 Then
        xRgStr = "b8"
    End If
    If xRgStr = "" Then Exit Sub
    
    Application.EnableEvents = False
    Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
    tSheet1.Range(xRgStr).Value = Target.Value
    Application.EnableEvents = True

End Sub
تم تصغير هذا التعليق بواسطة المشرف على الموقع
كريستال،

شكرا جزيلا لردك ، لقد نجح هذا! كيف يمكنني تعديل الكود لإضافة خلية أخرى في نفس الورقة 6 ، B3 والتي تحتاج أيضًا إلى المزامنة مع B8 في الورقة 7؟ لقد حاولت تعديله أدناه ، ولكن انتهى الأمر بوضع محتويات B3 في الورقة 6 في B7 في الورقة 7 بدلاً من B8.


ورقة عمل فرعية خاصة تغيير (هدف ByVal كنطاق)
'تم التحديث بواسطة Extendoffice 20221025
خافت tSheet1 كورقة عمل
خافت tRange1 كنطاق
خافت tRange2 كنطاق
خافت xRangeStr1 كسلسلة
خافت xRangeStr2 كسلسلة
على خطأ استئناف التالي
إذا كان Target.Count> 1 ، فاخرج من Sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

تعيين tRange1 = النطاق ("B7")
إذا لم يكن tRange1 لا شيء إذن
xRangeStr1 = tRange1.Address
Application.EnableEvents = خطأ
اضبط tSheet1 = ActiveWorkbook.Worksheets ("Sheet7")
tSheet1.Range (xRangeStr1) .Value = Target.Value
Application.EnableEvents = صحيح
إنهاء حالة

تعيين tRange2 = النطاق ("B8")
إذا لم يكن tRange2 لا شيء إذن
xRangeStr2 = tRange2.Address
Application.EnableEvents = خطأ
اضبط tSheet1 = ActiveWorkbook.Worksheets ("Sheet7")
tSheet1.Range (xRangeStr2) .Value = Target.Value
Application.EnableEvents = صحيح
إنهاء حالة

نهاية الفرعية
لا توجد تعليقات منشورة هنا حتى الآن
اترك تعليقاتك
النشر كضيف
×
قيم المنشور:
0   الشخصيات
المواقع المقترحة

تواصل معنا

حقوق التأليف والنشر © 2009 - شبكة الاتصالات العالمية.extendoffice.com. | كل الحقوق محفوظة. مشغل بواسطة ExtendOffice. | | خريطة الموقع
Microsoft وشعار Office هما علامتان تجاريتان أو علامتان تجاريتان مسجلتان لشركة Microsoft Corporation في الولايات المتحدة و / أو دول أخرى.
محمي بواسطة Sectigo SSL