اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

نسخ المعادلات والتنسيقات

asdhamdey

بواسطه asdhamdey
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

asdhamdey

asdhamdey

قام بنشر
قام بنشر

 

الاستاذ الكريم عبد الباري

هيا بنا نبحر في عملك القوي ليكون درسا للمهتمين بهذا المجال وليكون لك ولنا ان شاء الله عمل صالح ينتفع به

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

 

في صفحة الشيت الورقي يوجد زر سحري اسمه تحديث

وكوده الاتي

On Error GoTo kh_Err

تصفير_محدد

kh_Application False

'=============================================

kh_cFormula Range("شيت_الصف_الرابع!$c$2:$g$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$k$2:$L$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$p$2:$t$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$x$2:$y$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ac$2:$ag$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ak$2:$al$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ap$2:$at$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ay$2:$ba$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$bf$2:$bk$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$bo$2:$bp$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$bt$2:$bx$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ca$2:$cb$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ce$2:$ci$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$cl$2:$cm$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$cp$2:$ct$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$cw$2:$cx$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$da$2:$de$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$dh$2:$di$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$dl$2:$dr$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$dv$2:$dw$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$ea$2:$ek$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$em$2:$em$2"), 7, ورقة8.Range("b1")

kh_cFormula Range("شيت_الصف_الرابع!$eo$2:$ew$2"), 7, ورقة8.Range("b1")

'=============================================

kh_Err:

kh_Application True

If Err Then

MsgBox "Err.Number : " & Err.Number

Err.Clear

' Else: MsgBox " تم نسخ المعادلات بنجاح", vbMsgBoxRight, "الحمدلله"

End If

End Sub

' MyRng : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة

' iRow : اول صف للبيانات

' Lastrow : آخر صف للبيانات

Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long)

Dim Col As Range

Dim R As Long

'========================

For Each Col In MyRng.Cells

If Col.HasFormula Then

For R = iRow To Lastrow

With MyRng.Worksheet

.Cells(R, Col.Column).FormulaR1C1 = Col.FormulaR1C1

.Cells(R, Col.Column).Value = .Cells(R, Col.Column)

End With

Next R

End If

Next

'========================

Set Col = Nothing

End Sub

Sub kh_Application(ibol As Boolean)

With Application

.ScreenUpdating = ibol

.Calculation = IIf(ibol, -4105, -4135)

.EnableEvents = ibol

End With

End Sub

نرجو شرحه بارك الله فيك وجغل هذا العمل من باب علم ينتفع به

اخى الحبيب قصى

هذا الكود .... مسئول عن نسخ المعادلات الموجوده فى الصف الثانى ذو اللون الاسود وتطبيقها على باقى الشيت ابتداء من الصف السابع

واذا اردت شرحا وافيا ....حاضر من عينيا

 

هذا الكود .... مسئول عن نسخ المعادلات الموجوده فى الصف الثانى

اريد اضافة نسخ التنسيقات الموجوده بنفس الصف الثاني  جزاكم الله خيرا

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

الأخ الفاضل

يرجى مراجعة هذا الرابط وتطبيق التوجيهات

http://www.officena.net/ib/index.php?showtopic=60147

 

ولن يلتفت إليك الأخوة الأعضاء ما دمت لم تلتفت إلى التوجيهات (هااااام وضروري)

رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر (معدل)

الأخ الفاضل

يرجى مراجعة هذا الرابط وتطبيق التوجيهات

http://www.officena.net/ib/index.php?showtopic=60147

 

ولن يلتفت إليك الأخوة الأعضاء ما دمت لم تلتفت إلى التوجيهات (هااااام وضروري)

انت خلاص قررت ان الاخوة لا يلتفتوا الى موضوعي ..

عرفني ايه الحكايه الله يسامحك

تم تعديل بواسطه asdhamdey
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

والله أخي الفاضل حمدي

إنت حر

أنا مش بلزمك بشيء ومحدش يقدر يلزمك ..

بس طالما إن فيه قواعد .. يبقا صدقني الأخوة اللي بيقدموا المساعدة هيلتزموا بيها قبل الأعضاء اللي بيطلبوا المساعدة نفسهم ..دا لأنك لو ساعدت الناس الناس هتساعدك

حاجة تانية (ومش غرور مني لكن ثقة في الأعضاء ) - لو قلت بلاش نساعد فلاااااااان كله هيسمع كلامي .دا عشمي فيهم مش إجبار ليهم بردو :yes:

 

راجع التوجيهات بارك الله فيك والتزم بما جاء فيها قبل أي شيء ..ولو وجدت شيء لا يعجبك فيها أخبرني

رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر

هذا هو الملف

المطلوب

الصف رقم 1000 به معادلات واطارات اريد نسخه بمعادلاته وتنسيقاته في

 

 من الصف ال11 وحتى نهايه العدد الموجود في الخليه B4

وشكرا لتوجيهاتكم يابو ضحكة جنان

نسخ المعادلات والتنسيقات.zip

رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر 

Sub kh_Copy_Formula()
On Error GoTo kh_Err

kh_Application False

'=============================================
kh_cFormula Range("الاول!$b$5:$b$5"), 9, ورقة19.Range("b1")
kh_cFormula Range("الاول!$n$5:$u$5"), 9, ورقة19.Range("b1")
'=============================================

kh_Err:
kh_Application True

If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
'    Else: MsgBox " تم نسخ المعادلات بنجاح", vbMsgBoxRight, "الحمدلله"
End If
End Sub

' MyRng   : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة
' iRow    : اول صف للبيانات
' Lastrow : آخر صف للبيانات

Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long)
Dim Col As Range
Dim R As Long
'========================
For Each Col In MyRng.Cells
    If Col.HasFormula Then
        For R = iRow To Lastrow
            With MyRng.Worksheet
                .Cells(R, Col.Column).FormulaR1C1 = Col.FormulaR1C1
                .Cells(R, Col.Column).Value = .Cells(R, Col.Column)
            End With
        Next R
    End If
Next
'========================
Set Col = Nothing
End Sub

Sub kh_Application(ibol As Boolean)
With Application
    .ScreenUpdating = ibol
    .Calculation = IIf(ibol, -4105, -4135)
    .EnableEvents = ibol
End With
End Sub

Sub kh_Copy_Formula1()
On Error GoTo kh_Err

kh_Application1 False

'=============================================
kh_cFormula Range("الثانى!$b$5:$b$5"), 9, ورقة20.Range("b1")
kh_cFormula Range("الثانى!$n$5:$u$5"), 9, ورقة20.Range("b1")
'=============================================

kh_Err:
kh_Application1 True

If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
'    Else: MsgBox " تم نسخ المعادلات بنجاح", vbMsgBoxRight, "الحمدلله"
End If
End Sub

' MyRng   : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة
' iRow    : اول صف للبيانات
' Lastrow : آخر صف للبيانات

Sub kh_cFormula1(MyRng As Range, iRow As Integer, Lastrow As Long)
Dim Col As Range
Dim R As Long
'========================
For Each Col In MyRng.Cells
    If Col.HasFormula Then
        For R = iRow To Lastrow
            With MyRng.Worksheet
                .Cells(R, Col.Column).FormulaR1C1 = Col.FormulaR1C1
                .Cells(R, Col.Column).Value = .Cells(R, Col.Column)
            End With
        Next R
    End If
Next
'========================
Set Col = Nothing
End Sub

Sub kh_Application1(ibol As Boolean)
With Application
    .ScreenUpdating = ibol
    .Calculation = IIf(ibol, -4105, -4135)
    .EnableEvents = ibol
End With
End Sub

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

 

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الكريم

الملف يحتاج لوقت لدراسته .. إن شاء الله تجد المساعدة من الأخوة الأعضاء ..

وبعدين مفيش حد زعلان منك أبداً

تقبل تحياتي

رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر

وهذا هو الكود

Sub KH_Copy()
On Error Resume Next
Dim Last As Long
Dim Count As Integer
Count = 1
Count = Sheets("KHBOOR").Range("F9").Value
With ActiveSheet
    Last = .Range("A" & .Rows.Count).End(xlUp).Row
    .Rows(Last).Copy .Rows(Last + 1).Resize(Count)
    .Rows(Last + 1).Resize(Count).SpecialCells(xlConstants).ClearContents
End With
On Error GoTo 0
End Sub
رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر 
Option Explicit

'******************************************************
'  تعيين نطاق الخلايا التي يتم نسخها
Private Const MyRng_Copy As String = "B4:I4"
'------------------------------------------------------
' MyRng_Copy تعيين رقم العمود من النطاق
'   الذي سياخذ منه آخر صف للصق
Private Const MyColumn As Integer = 4
'******************************************************

Sub Kh_Insert_Rows()
On Error Resume Next
Dim MyRow As Integer, LastRow As Integer
MyRow = 1
MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & MyRow, Title:="ادراج عدد محدد من صفوف ", Default:=MyRow, Type:=1)
If MyRow = False Then Exit Sub
With Range(MyRng_Copy)
    LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count
    If LastRow = 0 Then LastRow = 1
    .Copy
    With .Offset(LastRow, 0).Resize(MyRow, .Columns.Count)
        .PasteSpecial xlPasteAll
        .SpecialCells(xlCellTypeConstants).ClearContents
    End With
    .Columns(1).Offset(LastRow, 0).Select
End With
Application.CutCopyMode = False
MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله"
On Error GoTo 0
End Sub


-------------------------------------------------------------------
Sub Kh_Clear_Rows()
On Error Resume Next
Dim LastRow As Integer
With Range(MyRng_Copy)
    LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count
    .SpecialCells(xlCellTypeConstants).ClearContents
    If LastRow = 0 Then GoTo 1
    .Cells(2, 1).Resize(LastRow, .Columns.Count).Clear
End With
1:
MsgBox "تم المسح بنجاح", 524288 + 1048576, "الحمدلله"
On Error GoTo 0
End Sub

هذا كود اخر لو تكرمتم اريد الحل في ملفي

رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر

المطلوب من كل هذه الاكواد المفيدة بارك الله في صانعها
 هو

مطلوب كود منهم يتم تطويعه

لينسخ الصف 1000 الموجود بالملف  ويتم لصقة ابتداء من الصف ال11 بالعدد الموجود في الخليه B4

بنفس معادلاته وتنسيقاته

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

رابط هذا التعليق
شارك
asdhamdey

asdhamdey

قام بنشر
  • الكاتب
قام بنشر

يبارك فيك ربنا يا استاذ عبد الباري

اولا يجب شكرك

ثانيا عند تغيير عدد الطلاب الموجود في الخليه بي 4 

المفروض ان يوجد هذا العدد من الصفوف فقط  مملوءه بالمعادلات والتنسيقات

 

الصف ال1000 ليه هو المطلوب  من اجل ان يتم الاستفاده القصوى من الكود لجميع الكنترولات  فبعضهم يبدأ من الصف 7 والاخر من الصف 11 والرقم متغير

اذن افضل حل هو الصف ال1000

رابط هذا التعليق
شارك
عبدالباري البنا

عبدالباري البنا

قام بنشر
قام بنشر

 

لو ان عدد الطلاب 500 

وبعد كده اردنا ان ندخل عدد الطلاب 100 فإن الصفوف ال500 تظل مملوءه بالمعادلات

نريد ان يلتزم الكود بعدد الطلاب فقط وتمسح الصفوف الغير ذلك

 

أخى العزيز 

جرب المرفق 

سوف يقوم بنسخ العدد المطلوب فقط

ويمسح باقى الصفوف

نسخ المعادلات والتنسيقات.rar

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

بارك الله فيك أخي وحبيبي في الله عبد الباري

كنت في بالي والله .. غبت عننا ليه لعله خير إن شاء الله

ننتظر تواجدك معنا وبيننا

رابط هذا التعليق
شارك
عبدالباري البنا

عبدالباري البنا

قام بنشر
قام بنشر

اخى العزيز اشكرك جدا على كلماتك الجميله

لكنى اقل بكثير من ان اتساوى باساتذة هذا الصرح العظيم

==============

جرب المرفق بعد التعديل واعلمنى بالنتيجة

 

نسخ المعادلات والتنسيقات.rar

رابط هذا التعليق
شارك
عبدالباري البنا

عبدالباري البنا

قام بنشر
قام بنشر

بارك الله فيك أخي وحبيبي في الله عبد الباري

كنت في بالي والله .. غبت عننا ليه لعله خير إن شاء الله

ننتظر تواجدك معنا وبيننا

اخى واستاذى وحبيبى فى الله.... استاذ ياسر

اولا : مبروك لهذا المنتدى الرائع ترقيه استاذ كبير وعظيم مثلك وصاحب ايادى بيضاء على الجميع...مبروك

ثانيا : والله بجد وحشتونى جدا وما منعنى كان اقوى منى لكن الحمد لله قدر الله وما شاء فعل

ثالثا : اسعدنى جدا جدا جدا سؤالك عنى ....ادام الله الحب والموده بيننا وادام الله عليك فضله ونعمته 

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept