ترحيل مع الاحتفاظ بتنسيق المصدر

[hayyan alaa]

اسعد الله اوقاتكم يا سادة

هل من الممكن عند ترحيل البيانات الاحتفاظ بتنسيقها في المصدر

ارجو منكم اعطائي ملف يتم فيه تنفيذ هذا الامر

[أحمد يوسف]

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

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

جرب هذا الكود في المثال المرفق

Option Explicit

Sub Macro_to_copy()
Sheets("Sheet1").Range("A1:I5").Copy
    With Sheets("Sheet2").Range("a1")
      .PasteSpecial (13)
      .PasteSpecial (3)
    End With
Application.CutCopyMode = False

End Sub

 

 

 

Copy_For_Me.xlsm

[hayyan alaa]

مشكورين أستاذ سليم

ساجرب و اقول لكم النتيجه

 

[hayyan alaa]

استاذ سليم عافاك الله  ما ارسلته لم ينجز العمل المطلوب في مايلي مرفق قد قمت حضرتك بانجازة مسبقا يناء على طلبي

وهو ملف يحتوي على صفحة ترحيل او ادخال الى صفحة فيها 11 صف وكلما اتم ادخال 11 صف تفتح صفحة جديدة فيها نفس الجدول (اتمنى ان تكون قد تذكرته)

ما اطلبه ان يكون الجدول الجديد في الصفحة المنشأة بنفس تنسيق الجدول في الصفحة التي تسبقها و التنسيف يشمل كل شيئ

من عرض الاعمدة وارتفاع الصفوف وتنسيق الخلايا من حيث الخط والرقم والتاريخ ان امكن

33_salim.xlsm

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

تم التعديل على الماكرو لينناسب مع المطلوب

Sub Salim_Macro_new()
Rem Created On 31/5/2019 By Salim Hasbaya
'Modefied on 29/6/2019
Application.ScreenUpdating = False
If Application.CountA(Sheets("Main").Range("a2:c2")) < 3 Then
 GoTo Leave_Me_Olone
 End If
Dim New_ro%
Dim t%: t = Sheets(Sheets.Count).Index
Dim target_sh As Worksheet
Dim M_sh As Worksheet
Dim last_ro%
  
  laste_ro = Sheets(t).Cells(Rows.Count, 1).End(3).Row
 Select Case laste_ro
  Case 11
    Set target_sh = Sheets.Add(after:=Sheets(t))
    With ActiveSheet
        .Name = "Salim" & t - 1
         Sheets("Main").Range("a1:c2").Copy
        '=====================
          With .Cells(1, 1)
            .PasteSpecial (xlPasteAll)
            .PasteSpecial (8)
          End With
        '========================
   End With
 Case Else
   
   Set target_sh = Sheets(Sheets.Count)
    With target_sh
       New_ro = .Cells(Rows.Count, 1).End(3).Row + 1
    '===========================
        Sheets("Main").Range("a2:c2").Copy
        With .Cells(New_ro, 1)
            .PasteSpecial (xlPasteAll)
            .PasteSpecial (8)
        End With
    End With
End Select
'==============================
Sheets("Main").Range("a2:c2").ClearContents
Leave_Me_Olone:
Sheets("Main").Select
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

29_6_2019_salim.xlsm