مرحبا فرانك
لا يستطيع Sory مساعدتك في ذلك.

مرحبا جيري ،
آسف لا أستطيع مساعدتك في ذلك. مرحبًا بك لنشر أي سؤال في منتدانا: https://www.extendoffice.com/forum.html للحصول على مزيد من دعم Excel من محترفي Excel أو غيرهم من محبي Excel.

ابحث عنها وقم بتغييرها في Array () و Intersect () و Worksheets () و PivotFields ()

PivotTable1
PivotTable2
PivotTable3
PivotTable4
H1
اسم الورقة
FIELDNAME

Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xPTabled As PivotTable
    Dim xPFiled As PivotField
    Dim xStr As String
    On Error Resume Next
    '리스트 만들기
    Dim listArray() As Variant
    listArray = Array("PivotTable1", "PivotTable2", "PivotTable3", "PivotTable4")
    If Intersect(Target, Range("H1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 0 To UBound(listArray)
        Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
        Set xPFile = xPTable.PivotFields("FieldName")
        'MsgBox (listArray(i))
        xStr = Target.Text
        xPFile.ClearAllFilters
        xPFile.CurrentPage = xStr
    Next
        Application.ScreenUpdating = True
End Sub

مرحبًا جيلمار ألفيس ،
آسف لا أستطيع مساعدتك في ذلك. مرحبًا بك لنشر أي سؤال في منتدانا: https://www.extendoffice.com/forum.html للحصول على مزيد من دعم Excel من محترفي Excel أو غيرهم من محبي Excel.

مرحبا،
هل تلقيت أي خطأ موجه؟ أحتاج إلى معرفة أكثر تحديدًا حول مشكلتك ، مثل إصدار Excel الخاص بك. وإذا كنت لا تمانع ، فحاول إنشاء بياناتك في كتاب عمل جديد وجرب agai ، أو التقط لقطة شاشة لبياناتك وقم بتحميلها هنا.

مرحبا جستن،
هل تلقيت أي خطأ موجه؟ أحتاج إلى معرفة أكثر تحديدًا حول مشكلتك.
قبل تطبيق الكود ، لا تنس تعديل "اسم الورقة""اسم الجدول المحوري""اسم مرشح الجدول المحوري" و ال الخلية تريد تصفية الجدول المحوري بناءً على (انظر sceenshot).

مرحبا كريستال ،

شكرا لمساعدتك. المشكلة هي أن الوظيفة لا تفعل شيئًا لسبب ما. بعض الإيضاحات:

الاسم المحوري: Order_Comp_B2C
اسم الورقة: ورقة الحساب
اسم الفلتر: رقم الأسبوع (لقد غيرت هذا الاسم مما كان عليه "إرسال أسبوع لا" في ملف البيانات)
الخلية المطلوب تغييرها: O26 و O27 (يجب أن يكون هذا في النطاق)

في هذا المحور ، أحاول تغيير عامل التصفية للأعمدة ، وليس لدي أي شيء في منطقة التصفية في قائمة حقول PivotTable.

الكود الخاص بي هو:

ورقة عمل فرعية خاصة تغيير (هدف ByVal كنطاق)
'تحديث بواسطة Extendoffice 20180702
خافت xPTable كـ PivotTable
خافت xP: ملف كـ PivotField
خافت xStr كسلسلة
على خطأ استئناف التالي
إذا كان التقاطع (الهدف ، النطاق ("O26")) لا شيء ، فاخرج من المنطقة الفرعية
Application.ScreenUpdating = خطأ
Set xPTable = Worksheets ("Calculation Sheet"). PivotTables ("Order_Comp_B2C")
تعيين xPFile = xPTable.PivotFields ("رقم الأسبوع")
xStr = الهدف
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = ترو
نهاية الفرعية

شكر،

جوستين

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

مرحبا كريستال ،

أرفق لقطة شاشة للمحور ، المربع الأحمر هو المرشح الذي أرغب في تغييره بناءً على قيمة الخلية.

على نحو مفضل ، أرغب في استخدام مجموعة من الخلايا تشير إلى عدة أرقام أسبوع.

شكر،

جوستين

مرحبا جستن،
آسف لم أر لقطة الشاشة التي أرفقتها على الصفحة. ربما هناك خطأ ما في الصفحة.
إذا كنت لا تزال بحاجة إلى حل المشكلة ، راسلني عبر البريد الإلكتروني zxm@addin99.com. آسف للإزعاج.

مرحبا جاستن تيو ，
يرجى تجربة كود فبا التالي. آمل أن أتمكن من المساعدة.

Private Sub Worksheet_Change(ByVal Target As Range)
    'Update by Extendoffice 20220706
    Dim I As Integer
    Dim xFilterStr1, xFilterStr2 As String
    On Error Resume Next
    If Intersect(Target, Range("O26:O27")) Is Nothing Then Exit Sub
    'Application.ScreenUpdating = False
    
    xFilterStr1 = Range("O26").Value
    xFilterStr2 = Range("O27").Value
    ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number"). _
        ClearAllFilters
    If xFilterStr1 = "" And xFilterStr2 = "" Then Exit Sub
    ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number"). _
        EnableMultiplePageItems = True
    xCount = ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems.Count

    For I = 1 To xCount
        If I <> xFilterStr1 And I <> xFilterStr2 Then
            ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems(I).Visible = False
        Else
            ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems(I).Visible = True
        End If
    Next

    'Application.ScreenUpdating = True
End Sub

مرحبًا maziaritib4 TIB ،
هذه الطريقة متاحة فقط لبرنامج Microsoft Excel. آسف للإزعاج.

مرحبا جيمس،

نعم ، هذا ممكن ، الكود الذي استخدمته لهذا هو (4 محاور ومراجع خليتين):

ورقة عمل فرعية خاصة تغيير (هدف ByVal كنطاق)
خافت أنا كعدد صحيح
Dim xFilterStr1، xFilterStr2، yFilterstr1، yfilterstr2 كسلسلة
على خطأ استئناف التالي
إذا تقاطع (الهدف ، النطاق ("O26: P27")) لا شيء ، ثم اخرج من الفرع الفرعي

xFilterStr1 = النطاق ("O26"). القيمة
xFilterStr2 = النطاق ("O27"). القيمة
yFilterstr1 = النطاق ("p26"). القيمة
yfilterstr2 = النطاق ("p27"). القيمة
ActiveSheet.PivotTables ("Order_Comp_B2C_Crea"). PivotFields ("رقم الأسبوع"). _
ActiveSheet.PivotTables ("Order_Comp_B2B_Crea"). PivotFields ("رقم الأسبوع"). _
ActiveSheet.PivotTables ("Order_Comp_B2C_Disp"). PivotFields ("رقم الأسبوع"). _
ActiveSheet.PivotTables ("Order_Comp_B2B_Disp"). PivotFields ("رقم الأسبوع"). _
ClearAllFilters

إذا كان xFilterStr1 = "" و xFilterStr2 = "" و yFilterstr1 = "" و yfilterstr2 = "" ثم اخرج من Sub
ActiveSheet.PivotTables ("Order_Comp_B2C_Crea"). PivotFields ("رقم الأسبوع"). _
ActiveSheet.PivotTables ("Order_Comp_B2B_Crea"). PivotFields ("رقم الأسبوع"). _
ActiveSheet.PivotTables ("Order_Comp_B2C_Disp"). PivotFields ("رقم الأسبوع"). _
ActiveSheet.PivotTables ("Order_Comp_B2B_Disp"). PivotFields ("رقم الأسبوع"). _
EnableMultiplePageItems = صحيح

xCount = ActiveSheet.PivotTables ("Order_Comp_B2C_Crea"). PivotFields ("رقم الأسبوع"). PivotItems.Count
xCount = ActiveSheet.PivotTables ("Order_Comp_B2B_Crea"). PivotFields ("رقم الأسبوع"). PivotItems.Count
yCount = ActiveSheet.PivotTables ("Order_Comp_B2C_Disp"). PivotFields ("رقم الأسبوع"). PivotItems.Count
yCount = ActiveSheet.PivotTables ("Order_Comp_B2B_Disp"). PivotFields ("رقم الأسبوع"). PivotItems.Count

لأني = 1 إلى xCount
إذا كنت <> xFilterStr1 وأنا <> xFilterStr2 ثم
ActiveSheet.PivotTables ("Order_Comp_B2C_Crea"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = False
ActiveSheet.PivotTables ("Order_Comp_B2B_Crea"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = False
آخر
ActiveSheet.PivotTables ("Order_Comp_B2C_Crea"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = True
ActiveSheet.PivotTables ("Order_Comp_B2B_Crea"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = True
إنهاء حالة
التالى

لأني = 1 إلى yCount
إذا كنت <> yFilterstr1 و <> yfilterstr2 ثم
ActiveSheet.PivotTables ("Order_Comp_B2C_Disp"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = False
ActiveSheet.PivotTables ("Order_Comp_B2B_Disp"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = False
آخر
ActiveSheet.PivotTables ("Order_Comp_B2C_Disp"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = True
ActiveSheet.PivotTables ("Order_Comp_B2B_Disp"). PivotFields ("رقم الأسبوع"). PivotItems (I) .Visible = True
إنهاء حالة
التالى

نهاية الفرعية

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

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/07/22
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next

xBoolean = False
Set xRg = Range("h6")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
    xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
    xBoolean = True
ElseIf Not (xDs Is Nothing) Then
    xBoolean = True
End If


If Not xBoolean Then Exit Sub

Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet1").PivotTables("Pivot Table 1")
Set xPFile = xPTable.PivotFields("Category")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True

End Sub

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

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

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220805
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next

xBoolean = False
Set xRg = Range("D3")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
    xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
    xBoolean = True
ElseIf Not (xDs Is Nothing) Then
    xBoolean = True
End If


If Not xBoolean Then Exit Sub
xStr = Format(xRg.Text, "m/d/yyyy")
Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet2").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Date")
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True

End Sub

مرحبًا Алексей ،

يرجى التحقق مما إذا كان رمز VBA في هذا التعليق #38754 يمكن أن تساعد.

مرحبًا Алексей ،

لا تحتاج إلى تعديل الكود ، ما عليك سوى إضافة رمز VBA إلى ورقة عمل الخلية التي تريد الرجوع إليها.
على سبيل المثال ، إذا كنت تريد تصفية جدول محوري باسم "PivotTable1"في Sheet2 بناءً على قيمة الخلية H6 in Sheet3، يرجى النقر بزر الماوس الأيمن فوق Sheet3 علامة تبويب ورقة العمل ، انقر فوق عرض الرمز من قائمة النقر بزر الماوس الأيمن ، ثم أضف الرمز إلى ملف الورقة 3 (الرمز) نافذة.