نقل بيانات من صفحة لأخرى مع نقل الارتباط التشعبي

[the-mask-999]

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

لدي ملف (مرفق) قمت بوضع بيانات في الشيت رقم (1)، وقمت بعمل ترحيل للبيانات لصفحة أخرى، ولكن المشكلة لدي أن الصفحة الأولى تحتوي خلاياها على ارتباط تشعبي، وعند عملية ترحيل البيانات لا يتم نقل الارتباط التشعبي المرتبط بالخلية.

فهل من طريقة لحل هذه الإشكالية.

طبعاً هدفي هو أنه أنه لدي معاملات في الصفحة الأولى مصنفة لعدة تصنيفات (صادر، وارد، تعاميم)، وفي كل صف مرتبط بارتباط تشعبي، وعند وضع التصنيف يتم نقل الصف تلقائياً للصفحة الخاصة بها.

أتمنى أجد الحل.

ولكم جزيل الشكر 

test.xlsm

[محمد هشام.]

Sub test()
Dim Sh As Worksheet: Dim WS As Worksheet: Set WS = Worksheets("data")
Dim I&, F As Range
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> WS.Name Then
Application.ScreenUpdating = False
For I = 3 To WS.Range("E" & Rows.Count).End(xlUp).Row
 If WS.Cells(I, "E") = Sh.Name Then
  WS.Range("A2:E2").Copy Destination:=Sh.Range("A1")
    Set F = WS.Range(WS.Cells(I, 1), WS.Cells(I, 5))
     F.Copy Destination:=Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
With Sh.Range("A2:E" & Sh.Range("A" & Rows.Count).End(xlUp).Row)
 .Interior.Color = xlNone: .EntireColumn.AutoFit
         End With
       End If
     Next I
  End If
Next Sh
Application.ScreenUpdating = True
End Sub

 

[the-mask-999]

أشكرك أخي الكريم محمد هشام على تفاعلك وإجابتك لي، 

ولكن المشكلة أنا بحاجة لترحيل البيانات وفقاً للملف الملف بمعنى، انا استعملت ماكرو لترحيل البيانات عن طريق (تصفية متقدمة)، أي أنه عند تعديل التصنيف أو الاسم في الصفحة الأولى يتم تغيير البيانات تلقائياً في الصفحات المرحل لها البيانات.

ومشكلتي هي في نقل خلايا صف (رقم القيد) التي يرتبط بها ارتباط تشعبي.

أرجو الرجوع لملفي المرفق وتعديل مثلاً كلمة الصادر في أحد الصفوف ...  فسترى تلقائياً أنه  سيتم حذف هذا الصف من صفحة الصادر.

مع شكري وتقديري

[ميدو63]

استاذنا الفاضل

تحية طيبة وبعد

أولا:-

الكود جميل ... اشكرك

ثانيا:-

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

لايتم النقل لشيت الوارد

ممكن التصحيح؟ .... فضلا وليس امرا

شكرا مرة أخرى

[بلانك]

بعد اذن الاستاذ محمد هاشم ://

صًلح اسم شيت الوارد باعادة التسمية .... من شيت داتا حاول تعمل كوبي لاسم الوارد وتضعة بدلا من الاسم القديم لان في اختلاف في الاسم رغم انة صحيح في الكتابة وافدني

[the-mask-999]

Sub Macro1()
'
' Macro1 ماكرو
'

'
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Sheets("data").Range("A2:E8    ").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("الصادر!Criteria"), CopyToRange:=Range("A1:E1"), _
        Unique:=False
End Sub
 

 

 

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

ولكم جزيل الشكر،،

تم تعديل فبراير 14 بواسطه the-mask-999

[محمد هشام.]

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

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

=MID(@CELL("filename";A1);FIND("]";@CELL("filename";A1))+1;31)

وفي حدث Private Sub Worksheet_Activate ضع الكود التالي 

Private Sub Worksheet_Activate()
Dim lRow2 As Long
 Set WS = Sheets("data"): Set dest = ActiveSheet
    If WS.AutoFilterMode Then WS.AutoFilterMode = False
    lRow2 = WS.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    On Error Resume Next
    If dest.[G2].Value = dest.Name Then
With WS.Range("A2:E" & lRow2)
    .AutoFilter Field:=5, Criteria1:=dest.[G2].Value
 Set Rng = WS.Range("A2:E" & lRow2).SpecialCells(xlCellTypeVisible)
  If Rng.Cells.Count > 1 Then
    With dest.Range("A2:F" & Rows.Count)
    .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = xlNone
  End With
 Rng.Copy dest.Range("A1")
End If
.AutoFilter
End With
End If
On Error GoTo 0
End Sub

 

TEST V2.xlsm

تم تعديل فبراير 14 بواسطه محمد هشام.
تعديل الكود

[the-mask-999]

يعطيك ألف عافية أخوي محمد هشام، هذا هو الملف المطلوب بالتحديد، وقمت ببعض التعديلات عليه ووسعت نطاق الأعمدة، لأني أضفت أعمدة إضافية للجدول اللي عندي، والحمد لله ظبط معي.

ماقصرت جزالك الله خير. عندي سؤال -غير هام- لقيت ماكرو في الملف اللي انت معدل عليه، ولكنه لا يعمل عند القيام بتشغيله. فهل له فائدة أو ماشابه.

[محمد هشام.]

منذ ساعه, the-mask-999 said:

سؤال -غير هام- لقيت ماكرو في الملف اللي انت معدل عليه، ولكنه لا يعمل عند القيام بتشغيله. فهل له فائدة أو ماشابه.

يسعدنا اننا استطعنا مساعدتك 😁

بالنسبة للماكرو يمكنك حدفه لا علاقة له بالمطلوب