(كود) نسخ خلايا من ورقة العمل الرئيسية إلى خلايا في أوراق عمل جديدة

[لعيونك]

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

تحية طيبة لكل الإخوة الفضلاء في هذا المنتدى المبارك،،،

 

لدي ورقة عمل رئيسية باسم " Master " و ورقة عمل فرعية باسم " 000 " ليتم النسخ منها

يوجد مجموعة أعمدة في الرئيسية 

أحتاج نسخ محتوى كل صف واحد إلى ورقة عمل جديدة منسوخة من الفرعية 

 

على فرض أن الكود يعمل التالي:

1- ينسخ ورقة العمل " 000 " لنسخة جديدة باسم " 001 " 

2- ينسخ محتويات الصف " 2 " في " Master " إلى ورقة العمل الجديدة " 001 "

3- خلية " A2 " في Master إلى " F5 " في 001  ،،،،

4- خلية " A3 " في Master إلى " F7 " في 001 ،،،،

5- خلية " A4 " في Master إلى " K7 " في 001 ،،،، وهكذا حتى انتهاء الخلايا

6- يعيد نسخ الورقة الفرعية " 000 " إلى نسخة جديدة باسم "  002 " ويعيد عملية النسخ ،، وهكذا ،،،،

 

مرفق المثال مع الشكر والتقدير وبالغ الامتنان

KPIs-Docs---FUNCTION.zip

[لعيونك]

السلام عليكم

الأخوة الكرام تم نسخ الشيت المطلوب وتكراره بهذا الكود

Sub Copier2()
    Dim x As Integer
    
    x = InputBox("Enter number of times to copy Sheet1")
    For numtimes = 1 To x
        'Loop by using x as the index number to make x number copies.
        'Replace "Sheet1" with the name of the sheet to be copied.
        ActiveWorkbook.Sheets("000").Copy _
           After:=ActiveWorkbook.Sheets("000")
    Next
End Sub

ثم تم تغيير اسم جميع الشيتس بهذا الكود

Sub ChangeWorkSheetName()
'Updateby20140624
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
newName = Application.InputBox("Name", xTitleId, "", Type:=2)
For i = 1 To Application.Sheets.Count
    Application.Sheets(i).Name = newName & i
Next
End Sub

 

إن وجد موضوع مساعد وميسر لعملية النسخ المتكررة أرجو إرشادي إليه

 

شكراً جزيلاً

[لعيونك]

بانتظار مساعدتكم في تكرار عملية النسخ من الورقة الرئيسية إلى 400 ورقة فرعية وأكثر

الأوراق الفرعية أسماءها تبدأ برقم 1 إلى 400 تقريباً

 

قضيت اليوم بحثاً ولم أتوصل لشيء

 

مرفق الملف بعد التحديث وإضافة الأوراق وإعادة تسميتها بالأكواد

 

جزاكم الله خيراً وقضى حاجاتكم وحاجات المسلمين

KPIs-Docs_2.zip

تم تعديل مارس 8, 2017 بواسطه لعيونك

[لعيونك]

لا إله إلا الله 

 

الإخوة الكرام

كمحاولة عملت التالي:

Sub CopyPaste()

Sheets("Master").Range("A2").Copy
Sheets("1").Range("F5").PasteSpecial xlPasteValues
Sheets("Master").Range("B2").Copy
Sheets("1").Range("F7").PasteSpecial xlPasteValues
Sheets("Master").Range("C2").Copy
Sheets("1").Range("K7").PasteSpecial xlPasteValues
Sheets("Master").Range("D2").Copy
Sheets("1").Range("F9").PasteSpecial xlPasteValues
Sheets("Master").Range("E2").Copy
Sheets("1").Range("F10").PasteSpecial xlPasteValues
Sheets("Master").Range("F2").Copy
Sheets("1").Range("K10").PasteSpecial xlPasteValues
Sheets("Master").Range("G2").Copy
Sheets("1").Range("F12").PasteSpecial xlPasteValues
Sheets("Master").Range("H2").Copy
Sheets("1").Range("K13").PasteSpecial xlPasteValues
Sheets("Master").Range("I2").Copy
Sheets("1").Range("F15").PasteSpecial xlPasteValues
Sheets("Master").Range("J2").Copy
Sheets("1").Range("K15").PasteSpecial xlPasteValues

End Sub

كيف يمكنني الآن إضافة عملية التكرار لينتقل للعمود التالي والورقة التالية؟

مرفق آخر تحديث بعد إزالة دمج الخلايا وإضافة الكود

KPIs-Docs_3.zip

تم تعديل مارس 9, 2017 بواسطه لعيونك

[سليم حاصبيا]

جرب هذا الماكرو

المرفق فيه كل التفاصيل

تم ازالة الخلابا المدمجة من الاوراق لانها تعيق عمل الماكرو

Sub Transfere_Data()
   lr = Sheets("Master").Range("A2").End(xlDown).Row
     If lr < 2 Then Exit Sub
   k = 2
   
    For i = 1 To Sheets.Count - 1
    If k > lr + 1 Then Exit Sub
      With Sheets(i + 1)
      Set my_rg = Sheets("Master").Range("a" & k & ":j" & k)
            .Range("d5") = my_rg.Cells(1)
            .Range("d6") = my_rg.Cells(2)
            .Range("g6") = my_rg.Cells(3)
            .Range("d8") = my_rg.Cells(4)
            .Range("d9") = my_rg.Cells(5)
            .Range("g9") = my_rg.Cells(6)
            .Range("d11") = my_rg.Cells(7)
            .Range("g12") = my_rg.Cells(8)
            .Range("d14") = my_rg.Cells(9)
            .Range("g14") = my_rg.Cells(10)
            k = k + 1
        End With
    Next

End Sub

 

KPIs-Docs Salim.rar

تم تعديل مارس 9, 2017 بواسطه سليم حاصبيا

[لعيونك]

14 دقائق مضت, سليم حاصبيا said:

جرب هذا الماكرو

المرفق فيه كل التفاصيل

تم ازالة الخلابا المدمجة من الاوراق لانها تعيق عمل الماكرو

Sub Transfere_Data()
   lr = Sheets("Master").Range("A2").End(xlDown).Row
     If lr < 2 Then Exit Sub
   k = 2
   
    For i = 1 To Sheets.Count - 1
    If k > lr + 1 Then Exit Sub
      With Sheets(i + 1)
      Set my_rg = Sheets("Master").Range("a" & k & ":j" & k)
            .Range("d5") = my_rg.Cells(1)
            .Range("d6") = my_rg.Cells(2)
            .Range("g6") = my_rg.Cells(3)
            .Range("d8") = my_rg.Cells(4)
            .Range("d9") = my_rg.Cells(5)
            .Range("g9") = my_rg.Cells(6)
            .Range("d11") = my_rg.Cells(7)
            .Range("g12") = my_rg.Cells(8)
            .Range("d14") = my_rg.Cells(9)
            .Range("g14") = my_rg.Cells(10)
            k = k + 1
        End With
    Next

End Sub

 

KPIs-Docs Salim.rar

شكراً جزيلاً أستاذ سليم

لا تسعفني الكلمات لأعبر لك عن خالص امتناني وشكري

جزاك الله خيراً وبارك فيك

تقبل احترامي وتقديري