نسخ النطاقات من شيت الى شيت أخر

[aaaaamine1]

السلام عليكم أساتذة و  رواد هذا المنتدى المميز و الرائع الرجاء عمل كود لنسخ نطاقات  معينة قد تكون (2 أو أكثر نطاق)

من ورقة معينة في الملف و لصقها و  تجميعها في  شيت أخر  من نفس الملف، كما هو موضح في الملف المرفق.

Classeur2021.xlsx

تم تعديل ديسمبر 10, 2021 بواسطه aaaaamine1

[aaaaamine1]

•  

 

تم تعديل ديسمبر 10, 2021 بواسطه aaaaamine1

[ابراهيم الحداد]

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

جرب هذا الكود

Sub Collected()
Dim ws As Worksheet, Arr As Variant, Tmp As Variant
Dim LR  As Long, LS As Long, Sh As Worksheet
Set ws = Sheets("Feuil1")
Set Sh = Sheets("تجميع")
t = Timer
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
Set Rng1 = ws.Range("A2:F" & ws.Range("B" & Rows.Count).End(3).Row)
Set Rng2 = ws.Range("H2:M" & ws.Range("I" & Rows.Count).End(3).Row)
Set Rng3 = ws.Range("O2:T" & ws.Range("P" & Rows.Count).End(3).Row)
Arr = Array(Rng1, Rng2, Rng3)
Application.ScreenUpdating = False
Sh.Range("A2:F1000").ClearContents
For i = LBound(Arr) To UBound(Arr)
Arr(i).Copy
LR = Sh.Range("B" & Rows.Count).End(3).Row + 1
Sh.Range("A" & LR).PasteSpecial xlPasteAll
Next
Application.CutCopyMode = False
LS = Sh.Range("B" & Rows.Count).End(3).Row
For j = 2 To LS
Sh.Range("A" & j) = j - 1
Next
Application.ScreenUpdating = True
'MsgBox Round(Timer - t, 2)
End Sub

 

[aaaaamine1]

أخي العزيز ابراهيم الحداد

بارك الله فيك و أشكرك على هذا العمل و الإبداع الرائع ،تمام مثل ما هو مطلوب

تقبل احترامي وتقديري و تحياتي الأخوية