كود لنسخ sheet جديد

[ابو يحيى1]

الاخوة الخبراء

هل يوجد كود يمكن به عمل نسخ للشيت المسمى ( نموذج ) تلقائياً كل يوم وتسميته بتاريخ اليوم فى الملف المرفق ؟

ارصدة.rar

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

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

انسخ هذا الكود فى موديول جديد وخصص له زر فى الورقة نموذج

Sub Copy_AddSheet()
Dim x As String
Sheet1.Range("A2:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Copy
x = WorksheetFunction.Text(Now(), Format("dd-mm-yyyy"))
For i = 1 To Sheets.Count
If Sheets(i).Name = x Then Exit Sub
Next i
Sheets.Add
With ActiveSheet
.Name = x
.Range("A2").PasteSpecial xlPasteValues
.Range("A2").PasteSpecial xlPasteFormats
.Range("A2").PasteSpecial xlPasteColumnWidths
End With
Application.CutCopyMode = False
End Sub

 

[ابو يحيى1]

شكراً أستاذنا  زيزو  وجزاك الله خيراً كود اكثر من رائع .

ولكن هل يمكن تنفيذ الآتى على هذه الورقة .

1- نسخ الخلايا بالحماية الموجودة عليها .

2- اعطاء لون عشوائى لكل شيت جديد آلياً .

3- الغاء تحديد الخلايا فى الشيت الجديد .

اذا كان اى نقطة من هذه النقاط متاح ارجوا المساعدة .

[ابو يحيى1]

شكراً أستاذنا  زيزو  وجزاك الله خيراً كود اكثر من رائع .

ولكن هل يمكن تنفيذ الآتى على هذه الورقة فى نفس الكود .

1.  نسخ الخلايا بالحماية الموجودة عليها .
2.  عمل إخفاء للأوراق القديمة .
3.  اعطاء لون عشوائى لكل شيت جديد آلياً .
4.  الغاء تحديد الخلايا فى الشيت الجديد .

اذا كان اى نقطة من هذه النقاط متاح ارجوا المساعدة .

تم تعديل أبريل 7, 2017 بواسطه ابو يحيى1

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

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

تم تنفيذ كل ماطلبته ما عدا تلوين الشيت لانه سيستغرق وقتا طويلا اثناء التنفيذ

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

اليك الملف بعد التعديل

 

ارصدة.rar

تم تعديل أبريل 7, 2017 بواسطه زيزو العجوز

[ابو يحيى1]

استاذنا الجليل كلمات الشكر لا توفيك حقك

فعلا حضرتك اوضحت كل ما احلم به

وهل من الممكن الحماية بكلمة سر ؟

وعذرا فالمقصود بالتلوين هو تلوين Tap color وليس تلوين الخلايا بداخل الشيت .

عموما اكرر شكرى لحضرتك زادك الله علما على علم .

 

تم تعديل أبريل 7, 2017 بواسطه ابو يحيى1

[حمادة عمر]

السلام عليكم

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

بارك الله فيك

بعد اذن الاخ والاستاذ الحبيب / زيزو العجوز .. جزاه الله خيرا

وبنفس اكواده الراائعة قم باستبدال الكود الخاص بالنسخ بالكود التالي بزيادة سطر واحد فقط وهو

Call SheetColors55

ليكون الكود كالتالي :

Sub Copy_AddSheet()
Dim x As String
Sheet1.Unprotect
Sheet1.Range("A2:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Copy
x = WorksheetFunction.Text(Now(), Format("dd-mm-yyyy"))
For i = 1 To Sheets.Count
If Sheets(i).Name = x Then Exit Sub
If Sheets(i).Name <> "form" Then
Sheets(i).Visible = xlSheetHidden
End If
Next i
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = x
With ActiveSheet
.Range("A2").PasteSpecial xlPasteValues
.Range("A2").PasteSpecial xlPasteFormats
.Range("A2").PasteSpecial xlPasteColumnWidths
.DisplayRightToLeft = False
.Range("A2").Select
.Protect
End With
'===================================
Call SheetColors55
'===================================
Sheet1.Protect
Application.CutCopyMode = False
End Sub

وذلك بعد اضافة الكود التالي في موديل ( هو نفس كود الاستاذ / زيزو العجوز .. والخاص بالتلوين ولكن بتعديل بسيط جدا )

ليصبح التلوين للشيت في نفس خطوة وامر النسخ بضغطة زر واحدة

Sub SheetColors55()
Dim x, y, z As Integer
x = WorksheetFunction.RandBetween(0, 255)
y = WorksheetFunction.RandBetween(0, 255)
z = WorksheetFunction.RandBetween(0, 255)
colr = VBA.RGB(x, y, z)
On Error Resume Next
ActiveSheet.Select
    ActiveSheet.Tab.Color = colr
End Sub

تقبلوا خالص تحياتي

وجزاكم الله  خيرا

[ابو يحيى1]

شكرا استاذى حمادة عمر

تعديل ممتاز وهو المطلوب فعلا جزاك الله خيراً انت واستاذنا زيزو العجوز

[حمادة عمر]

جزاك الله خيرا