ارجو المساعده فى كود فتح ملف جديد

[إبراهيم ابوليله]

الاخوه الكرام

المطلوب

هو انه بعد انشاء ملف جديد

ونقل البيانات اليه

يتم الرجوع مره اخرى الى الشيت الاصلى

WOR.rar

[شوقي ربيع]

السلام عليكم

كل ماعليك اضافة عبارة  Sheet2.Activate اخر الكود

Sub workbookAdd()
'ßæÏ ÝÊÍ ãáÝ ÌÏíÏ

  
            Sheet1.Select
            Range("A3:A15").Copy
    Workbooks.Add
    numWorkbooks = Workbooks.Count
Worksheets(1).Select
ActiveSheet.Paste
ActiveSheet.Columns("A:g").Select
 Selection.ColumnWidth = 15
ActiveSheet.DisplayRightToLeft = False
Sheet2.Activate
End Sub

[إبراهيم ابوليله]

اخى شوقى

بارك الله فيك

ولكن هل يمكن الرجوع مره اخرى الى

الملف الذى تم اضافته

--------------------------------

لاننى بالمعنى الاصح

اريد ان اقوم بنسخ البيانات من شيت 1 الى شيت 1 فى الملف الذى تم اضافته

ثم نسخ البيانات من شيت 2 الى شيت 2 فى الملف الذى تم اضافته

[شوقي ربيع]

السلام عليكم

جرب هذا اعتقد انه يفي بلغرض

Sub Test()
    Dim Wkb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("MAIN")
    
    Workbooks.Add
    Set Wkb = ActiveWorkbook
        Wkb.Worksheets(1).Range(ws1.Range("A3:A15").Address).Value = ws1.Range("A3:A15").Value
        
        Wkb.Sheets.Add Before:=Worksheets(Worksheets.Count)
        Wkb.Worksheets(1).Range(ws2.Range("A3:A15").Address).Value = ws2.Range("A3:A15").Value
        
        ws2.Activate
End Sub

[إبراهيم ابوليله]

اخى شوقى

مشكورا على الرد والاجابة الدقيقه

بارك الله فيك

ولكن ماذا لو اردنا نقل بيانات الشيت الثالث ايضا

كيف سيكون شكل الكود

[إبراهيم ابوليله]

اخى واستاذنا

شوقى

مش عارف اققولك ايه

بس يكفيك دعاءى لك

بارك الله فيك

وذادك من فضله وعلمه

----------------------------------------

الحمد لله تم التوصل الى المطلوب

-------------------------------------------

واعتقد الكود سيكون بالشكل الاتى

Sub workbookAdd_WITH_COPY()
'ßæÏ ÝÊÍ ãáÝ ÌÏíÏ
    Dim Wkb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    
    Set ws1 = ThisWorkbook.Sheets("ADD NEW SHEET")
    Set ws2 = ThisWorkbook.Sheets("ADD NEW WITOUT REPEAT WIHT COPY")
        Set ws3 = ThisWorkbook.Sheets("OPEN NEW WORKBOOK WITH COPY")

    Workbooks.add
    Set Wkb = ActiveWorkbook
        Wkb.Worksheets(1).Range(ws1.Range("A3:A15").Address).Value = ws1.Range("A3:A15").Value
        
        Wkb.Sheets.add after:=Worksheets(Worksheets.Count)
        Wkb.Worksheets(2).Range(ws2.Range("A3:A15").Address).Value = ws2.Range("A3:A15").Value
                Wkb.Sheets.add after:=Worksheets(Worksheets.Count)
        Wkb.Worksheets(3).Range(ws3.Range("A3:A15").Address).Value = ws3.Range("A3:A15").Value

        ws3.Activate
        End Sub

اخى شوقى اذا كان هناك حل اخر ارجو ارفاقه

مشكورا اخى الحبيب

[شوقي ربيع]

السلام عليكم

تما هو ذاك لاضافة ورقة اخرى

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

اذا اردت تحديد الاوراق التي سترحل كل ما عليك ضبط طول الحلقة التكرارية

Sub Test()
    Dim Wkb1 As Workbook, Wkb2 As Workbook
    Dim wsh As Worksheet
    Dim i As Byte
    
    Set Wkb1 = ActiveWorkbook
    Workbooks.Add
    Set Wkb2 = ActiveWorkbook
    
For i = 1 To Wkb1.Worksheets.Count
    Set wsh = Wkb1.Worksheets(i)
    Wkb2.Worksheets(i).Range(wsh.Range("A3:A15").Address).Value = wsh.Range("A3:A15").Value
Next

End Sub

[إبراهيم ابوليله]

 

السلام عليكم

جرب هذا اعتقد انه يفي بلغرض

Sub Test()
    Dim Wkb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("MAIN")
    
    Workbooks.Add
    Set Wkb = ActiveWorkbook
        Wkb.Worksheets(1).Range(ws1.Range("A3:A15").Address).Value = ws1.Range("A3:A15").Value
        
        Wkb.Sheets.Add Before:=Worksheets(Worksheets.Count)
        Wkb.Worksheets(1).Range(ws2.Range("A3:A15").Address).Value = ws2.Range("A3:A15").Value
        
        ws2.Activate
End Sub

اخى شوقى

هل يمكن نسخ التنسيقات كما هى

نوع الخط--الحدود-الالوان