اذهب الي المحتوي
أوفيسنا

أرجو مساعدتي في تصحيح هذا الكود

أم عبد الله

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

 مشاركة

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

أم عبد الله

أم عبد الله

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

السادة الكرام أعضاء هذا المنتدى الرائع حاولت أن أتعلم الأكواد الخاصة بالاكسيل ولكني فشلت وعملت ماكرو ولكن لا يفي بالمطلوب الذي أرغبه فأرجو مساعدتي في تصحيحه ولكم جزيل الشكر.

fz5555.rar

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

عبدالله المجرب

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

السلام عليكم

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

==

بما ان الترقيم تلقائي لما لا يتم استعمال الاسم في النقل (ما رايك)

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

أم عبد الله

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

أستاذي الفاضل

أولاً أما آسف مرة أخرى وكل عام وأنتم بخير ولك جزيل الشكر على إهتمام حضرتك بطلبي ولا يوجد مانع باستعمال الاسم ولك مني كل التقدير والتحية وجعله الله في ميزان حساناتك ورزقنا الله الفردوس الأعلى مع الحبيب المصطفى صلى الله عليه وسلم .

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

أم عبد الله

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

الاستاذ / عبد الله المجرب

كل عام وأنتم بخير ولك جزيل الشكر على إهتمام حضرتك بطلبي ويمكن عمل قائمة بالأسماء واختيار منها الاسم المراد نقله وجزاك الله خيراً وجعله الله في ميزان حساناتك.

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

أم عبد الله

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

استاذي الفاضل / عبد الله المجرب

تم عمل قائمة بالأسماء واختيار منها الاسم المراد فأرجو تعديل الكود الذي يجعل اختياري لاسم موظف من القائمة يتم نقله قي صفحة المنقولون مع احلال الصف الذي يليه مباشرة في صفحة البيانات وهكذا لاختياري نقل أكثر من موظف وجزاك الله خيراً وجعله الله في ميزان حساناتك.

fz55.rar

تم تعديل بواسطه fzsss
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم


Public Sub Ali_T()

Dim Sh As Worksheet

Dim r As Range, Rn As Range

Set r = Range("G2")

Set Sh = ورقة2

With Sh

For Each Rn In .Range("B6:B" & .Cells(Rows.Count, 1).End(xlUp).Row)

If Rn = r.Value Then

.Range(Cells(Rn.Row, 2).Address, Cells(Rn.Row, 24).Address).Copy

With Sheets("المفقولون")

	 .Select

.Range("B" & .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues

End With

sss.Select

End If

Next
حل بطريقة اخرى انسخ الكود في حدث الزر في ورقة الرئيسية 

Dim Sh As Worksheet, S As Worksheet

Dim r As Range, Rn As Range, Rr%

Set r = Range("G2")

Set S = ورقة3

Set Sh = ورقة2

Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row)

With Rn

For Rr = 1 To .Rows.Count

If .Cells(Rr, 1).Value = r.Value Then

	 Rn.Rows(Rr).Copy

	 S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues

	 Exit For

End If

Next

Application.CutCopyMode = False

End With

fz55_Ali.rar

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

أم عبد الله

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

أخي العزيز

جزاك الله خيراً على المساعدة وكل عام وأنتم بخير ولكن أرجو أن يحذف اسم الموظف من ورقة البيانات بعد نقله في ورقة المنقولين ولكم جزيل الشكر.

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

بعد تنفيذ الكود

خلية " G2 " في ورقة الرئيسية

في قائمة التحقق من الصحة حط هذه المرجع 

=Data
وهذا الكود وبه تعديل لحذف الاسم من ورقة البيانات بعد نقله 

Private Sub الريئسية_Click()

Dim Sh As Worksheet, S As Worksheet

Dim r As Range, Rn As Range, Rr%, A%, B%

Set r = Range("G2")

Set S = ورقة3

Set Sh = ورقة2

Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row)

On Error Resume Next

With Rn

For Rr = 1 To .Rows.Count

   If .Cells(Rr, 1).Value = r.Value Then

	 .Rows(Rr).Copy

	  S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues

	  B = .Range(.Cells(Rr, 17), .Cells(Rr, 23)).Copy

	  A = .Cells(Rr, 1).Row

	 Exit For

   End If

Next

With Sh

.Cells(A, 1).EntireRow.Delete Shift:=xlUp

.Application.ScreenUpdating = False

.Application.EnableEvents = False

.Range(.Cells(6, 18), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 24)).PasteSpecial xlPasteFormulas

.Range(.Cells(6, 18), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 18)).FormulaR1C1 = "=FLOOR((RC[-7]+RC[-5])*R1C16,0.01)"

.Range(.Cells(6, 19), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 19)).FormulaR1C1 = "=FLOOR((RC[-7]+RC[-6])*R1C18,0.01)"

.Range(.Cells(6, 20), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 20)).FormulaR1C1 = "=SUM(RC[-6]:RC[-2])"

.Range(.Cells(6, 21), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 21)).FormulaR1C1 = _

"=IF(R[1]C[113]=""احتساب"",SUM(RC[-7]:RC[-2])*(R[1]C[111]-R[1]C[110])/R[1]C[111],SUM(RC[-7]:RC[-2]))"

.Range(.Cells(6, 22), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 22)).FormulaR1C1 = _

"=IF(RC[-19]=""مدير عام أ"",10,IF(RC[-19]=""مدير عام"",6,IF(RC[-19]=""الأولى"",5,IF(RC[-19]=""الثانية"",5,IF(RC[-19]=""الثالثة"",4,IF(RC[-19]=""الرابعة"",2,IF(RC[-19]=""الخامسة"",1.5,IF(RC[-19]=""السادسة"",1.5,0))))))))"

.Range(.Cells(6, 23), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 23)).FormulaR1C1 = _

"=IF(R[1]C[111]=""احتساب"",SUM(RC[-12],RC[-10])*(R[1]C[109]-R[1]C[108])/R[1]C[109],SUM(RC[-12],RC[-10]))"

.Range(.Cells(6, 24), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 24)).FormulaR1C1 = _

"=IF(R[1]C[110]=""احتساب"",SUM(RC[-12],RC[-11])*(R[1]C[108]-R[1]C[107])/R[1]C[108],SUM(RC[-12],RC[-11]))"

.Range(.Cells(6, 2), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data"

.Application.EnableEvents = True

.Application.ScreenUpdating = True

End With

Application.CutCopyMode = False

sss.Select

End With

End Sub

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

أم عبد الله

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

أخي الأستاذ / عباد

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

كل عام وأنتم بخير أنا عاجز عن الشكر وجزاك الله خيراً. أنا جربت الكود وأكثر من رائع ولكن يوجد خلل عند الحذف في ورقة الاجمالي وبقية الأوراق لأن ورقة الاجمالي مرتبطة بورقة البيانات فأرجو تعديل في الكود وبدل الحذف يتم احلال الصفوف مكان الموظف الذي تم نقله وبذلك نتفادى المشاكل في الصفحات الأخرى. وهل يمكن شرح عمل هذا الكود لكي أطبقه على بقية الملفات التي أحتاج إليها أكون عاجز عن الشكر.

تم تعديل بواسطه fzsss
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

كل عام وانت بخير fzsss

عيدك مبارك وكل سنه وانت بصحه وسلامه إن شاء الله

هذا الكود في حدث ورقة " الرئيسية "


Private Sub الريئسية_Click()

Call Ali_T

End Sub
وهذه الأكواد في مودويل 

Type S_Ali

V_A As Variant

D_A As String

End Type

Public Work As Workbook

Public Ali_Sh As Worksheet

Public Ali_Rn() As S_Ali

Public Sub Ali_T()

Dim Sh As Worksheet, S As Worksheet

Dim R As Range, Rn As Range, Rr%, E, EE

Dim Rtt As Range

Set R = Range("G2")

Set S = ورقة3

Set Sh = ورقة2

Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row)

On Error Resume Next

With Rn

For Rr = 1 To .Rows.Count

If .Cells(Rr, 1).Value = R.Value Then

	 .Rows(Rr).Copy

	 S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues

	 .Rows(Rr).ClearContents

	 a = .Cells(Rr, 1).Row

	 Exit For

End If

Next

With Application

	 .ScreenUpdating = False

	 .EnableEvents = False

b = Sh.Cells(Rows.Count, 2).End(xlUp).Row

With Sh

Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 24).Address)

	 If TypeName(Rtt) <> "Range" Then Exit Sub

	 ReDim Ali_Rn(Rtt.Count)

	 Set Work = ActiveWorkbook

	 Set Ali_Sh = Sh

	 i = 0

	 For Each CE In Rtt

		 i = i + 1

		 Ali_Rn(i).D_A = CE.Address

		 Ali_Rn(i).V_A = CE.Formula

	 Next CE

	 .Range(.Cells(a, 2).Address, .Cells(b, 15).Address).ClearContents

End With

	 .EnableEvents = True

	 .ScreenUpdating = True

	 End With

Application.CutCopyMode = False

Call Ali_Set

End With

End Sub

Sub Ali_Set()

With Application

.ScreenUpdating = False

.EnableEvents = False

On Error GoTo Err

Work.Activate

Ali_Sh.Activate

For i = 1 To UBound(Ali_Rn)

Range(Ali_Rn(i).D_A).Offset(-1, 0).Formula = Ali_Rn(i).V_A

Next i

Range(Cells(6, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data"

sss.Activate

.ScreenUpdating = True

.EnableEvents = True

End With

Exit Sub

Err:

MsgBox "Err Not Recv"

End Sub

***************************************

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

***************************************

Ali_fzsss_Data_2003.rar

Ali_fzsss_Data_2007.rar

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

أم عبد الله

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

أستاذي الفاضل / عباد

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

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

متشكر جداً لحضرتك على هذا الماكرو وهذا الكود وعمل أكثر من رائع ويكون لك كل الفضل إذا تكرمت وشرحت لي هذا العمل لأنني حينما طبقته على عمل عندي اكتفى بعدد الأعمدة السابقة وحذف باقي الأعمدة وملفي يحتوي على عدد أعمدة كبير جداً يصل إلى 250 عمود وعدد الصفوف تصل لأكثر 600 صف ويحتوي على أكثر من أربع ورقات على معادلات أبضاً أو يمكن تعديل الكود بهذه البيانات ولك كل الشكر والتقدير.

تم تعديل بواسطه fzsss
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

وضحت لك الاسطر التي تتغير

اذا تغير المدى حسب الملف السابق


Public Sub Ali_T()

Dim Sh As Worksheet, S As Worksheet

Dim R As Range, Rn As Range, Rr%, E, EE

Dim Rtt As Range

Set R = Range("G2")

Set S = ورقة3

Set Sh = ورقة2

'***************************************************************

' المدى المحدد من عمود B6:X

'  بإمكانك تغيره حسب الأعمدةالمراده مثال  B6:IP

Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row)

'***************************************************************

On Error Resume Next

With Rn

For Rr = 1 To .Rows.Count

   If .Cells(Rr, 1).Value = R.Value Then

	 .Rows(Rr).Copy

	 S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues

	 .Rows(Rr).ClearContents

	 a = .Cells(Rr, 1).Row

	 Exit For

   End If

Next

With Application

	    .ScreenUpdating = False

	    .EnableEvents = False

    b = Sh.Cells(Rows.Count, 2).End(xlUp).Row

With Sh

'***************************************************************

'IP'الى 250 الذي هو عمود 'X' تغير المدى حسب المراد مثلا بدل 24 الذي هو

Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 24).Address)

'***************************************************************

	    If TypeName(Rtt) <> "Range" Then Exit Sub

	    ReDim Ali_Rn(Rtt.Count)

	    Set Work = ActiveWorkbook

	    Set Ali_Sh = Sh

	    i = 0

	    For Each CE In Rtt

		    i = i + 1

		    Ali_Rn(i).D_A = CE.Address

		    Ali_Rn(i).V_A = CE.Formula

	    Next CE

'***************************************************************

' هنا حذف اعمدة البيانات فقط بدون الاعمدة التي بها صيغ

' اذا تغير مدى البيانات في ملفك الاصل غيره من هنا

	    .Range(.Cells(a, 2).Address, .Cells(b, 15).Address).ClearContents

'***************************************************************

End With

	    .EnableEvents = True

	    .ScreenUpdating = True

	 End With

Application.CutCopyMode = False

Call Ali_Set

End With

End Sub

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

أم عبد الله

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

السلام عليكم ورحمة الله وبركاته أخي الفاضل / عباد

أنا عاجز عن الشكر وتم تغيير الأعمدة والكود يعمل جيداً ولكن بالنسبة للصفوف هل يمكن تغييرها لأنها عند نقل الموظف وحذف الموظف من صفحة البيانات يوجد خلل في ترتيب بعض الصفوف وحاولت فهم بعض الحلقات التكرارية لفهم الكود وتصليحه ولكن فشلت قي الصفوف يمكن فكرت في حل لهذه المشكلة وهى يتم نسخ الموظف المراد نقله أولاً في صفحة المنقولين وبعدها يتم نسخ جميع صفوف الأسماء بعد الموظف الذي تم نقله زائد عليها صف كامل فارغ ولصقها على الموظف وبذلك يتم الاحتفاظ ببيانات الموظفين والمعادلات الخاصة بهم. وجزاك الله خيراً.

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

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

لاشكر على واجب اخي fzsss

ارجو منك ارفاق مثال من ملفك الاصلي

بيانات وهميه كي اعرف المدى المطلوب تنفيذ الكود عليه

وان شاء الله يتم عمل اللازم وتوضيح ماتم تعديله على الكود

كي تعدل في حال تغير المدى

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

أم عبد الله

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

أستاذي الفاضل / عباد

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

أنا عاجز عن الشكر لتلبية طلبي وجزاكم الله خيراً على تعب حضرتك.

أولاً : ما أود عمله هو عند اختيار اسم الموظف المراد نقله يتم نسخه من ورقة البيانات ولصقه في ورقة المنقولون لكي يحتفظ بالمعادلات وبياناته لاحتمال رجوعه بعد شهر أو أكثر.

ثانياً : يتم نسخ كل الصفوف التي تلي اسم الموظف الذي تم نقله حتى الصف 400 فقط وليس لنهاية البيانات لأنها ثابتة ويتم لصقها على الموظف المنقول في صفحة البيانات وبذلك نتفادى أي أخطاء الناتجة من الحذف وباقي الأوراق لا يتم التعديل بها ولك كل التقدير والاحترام.ومرفق لحضرتك الملف.

fz10.rar

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

الكود يعمل مثل ماتفضل بشرحه


[color=#008000][size=5][font='times new roman', times, serif][b]ثانياً : يتم نسخ كل الصفوف التي تلي اسم الموظف الذي تم نقله حتى الصف 400 فقط وليس لنهاية البيانات لأنها ثابتة ويتم لصقها على الموظف المنقول في صفحة البيانات وبذلك نتفادى أي أخطاء الناتجة من الحذف وباقي الأوراق لا يتم التعديل بها[/b][/font][/size][/color]
وهذا تعديل بسيط لنسخ المعادلات 

Type S_Ali

V_A As Variant

D_A As String

End Type

Public Work As Workbook

Public Ali_Sh As Worksheet

Public Ali_Rn() As S_Ali

Public Sub Ali_T()

Dim Sh As Worksheet, S As Worksheet

Dim R As Range, Rn As Range, Rr%, E, EE

Dim Rtt As Range

Set R = Range("G2")

Set S = ورقة3

Set Sh = ورقة2

Set Rn = Sh.Range("B6:IP" & Sh.Cells(Rows.Count, 2).End(xlUp).Row)

On Error Resume Next

With Rn

For Rr = 1 To .Rows.Count

If .Cells(Rr, 1).Value = R.Value Then

		 .Rows(Rr).Copy

		 S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteFormulasAndNumberFormats

		 .Rows(Rr).ClearContents

		 a = .Cells(Rr, 1).Row

		 Exit For

End If

Next

With Application

		 .ScreenUpdating = False

		 .EnableEvents = False

		 .Calculation = xlCalculationManual

b = Sh.Cells(Rows.Count, 2).End(xlUp).Row

With Sh

Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 250).Address)

		 If TypeName(Rtt) <> "Range" Then Exit Sub

		 ReDim Ali_Rn(Rtt.Count)

		 Set Work = ActiveWorkbook

		 Set Ali_Sh = Sh

		 I = 0

		 For Each CE In Rtt

				 I = I + 1

				 Ali_Rn(I).D_A = CE.Address

				 Ali_Rn(I).V_A = CE.Formula

		 Next CE

		 .Range(.Cells(a, 2).Address, .Cells(b, 250).Address).ClearContents

End With

		 .Calculation = xlCalculationManual

		 .EnableEvents = True

		 .ScreenUpdating = True

		 End With

Application.CutCopyMode = False

Call Ali_Set

End With

End Sub

Sub Ali_Set()

With Application

.ScreenUpdating = False

.EnableEvents = False

.Calculation = xlCalculationManual

Work.Activate

Ali_Sh.Activate

For I = 1 To UBound(Ali_Rn)

Range(Ali_Rn(I).D_A).Offset(-1, 0).Formula = Ali_Rn(I).V_A

Next I

Range(Cells(6, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data"

sss.Activate

.Calculation = xlCalculationManual

.ScreenUpdating = True

.EnableEvents = True

End With

Exit Sub

End Sub

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

أم عبد الله

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

السلام عليكم ورحمة الله وبركاته أخي الفاضل / عباد

أنا عاجز عن الشكر وجزاك الله خيراً على هذا التعب ولكن الكود بطئ جداً ونفس المشكلة ينسخ معلومات الموظف كاملة كأرقام وليس معادلات في الخلايا التي بها معادلات. واضح إن الأمر مرهق لذلك أرجو من حضرتك كود واحد فقط هو عند اختياري لاسم موظف من القائمة المنسدلة في صفحة الرئيسية يقف على اسم هذا الموظف في صفحة البيانات ولك كل التحية والتقدير.

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

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

اخي الفاضل fzsss

ولكن الكود بطئ جداً ونفس المشكلة ينسخ معلومات الموظف كاملة كأرقام وليس معادلات

هل تقصد في ورقة المنقولون أم ورقة البيانات ؟

أنا مجرب الكود ينسخ المعادلات في كلا الورقتين

في حالة نسخ الموظف الى ورقة المنقولون وفي حالة نسخ البيانات التاليه الى الصف المرحل ومايليه في ورقة البيانات

أرجو التأكد من عمل الكود

إلى أن أعدل على الكود لبطئه فعلا

أو استعبضه بكود اخر

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

أم عبد الله

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

أستاذي الفاضل / عباد

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

لا ينسخ المعادلات في ورقة المنقولين ينسخ المعادلات كأرقام وأما في ورقة البيانات لا يأخذ ترتيب الصفوف في نسخ المعادلات بمعنى لو وقفت على الخلية المكتوب فيها المعادلة بعد النقل تجدها بالترتيب التي كانت عليه وليس الترتيب الجديد. ولك جزيل الشكر.

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

جرب هكذا


Type S_Ali

V_A As Variant

D_A As String

End Type

Public Sub Ali_T()

Dim Ali_Rn() As S_Ali

Dim Sh As Worksheet, S As Worksheet, Sn As Worksheet

Dim R As Range, Rn As Range, Rr%, E, EE

Dim CE As Range

Dim Rtt As Range

Set R = Range("G2")

Set S = ورقة3

Set Sh = ورقة2

Set Sn = ورقة1

Set Rn = Sh.Range("B6:IP" & Sh.Cells(Rows.Count, 2).End(xlUp).Row)

On Error Resume Next

With Rn

For Rr = 1 To .Rows.Count

If .Cells(Rr, 1).Value = R.Value Then

		 .Rows(Rr).Copy

		 S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteFormulasAndNumberFormats

		 .Rows(Rr).ClearContents

		 a = .Cells(Rr, 1).Row

		 Exit For

End If

Next

With Application

		 .ScreenUpdating = False

		 .EnableEvents = False

		 .Calculation = xlCalculationManual

b = Sh.Cells(Rows.Count, 2).End(xlUp).Row

With Sh

Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 250).Address)

		 If TypeName(Rtt) <> "Range" Then Exit Sub

		 ReDim Ali_Rn(Rtt.Count)

		 I = 0

		 For Each CE In Rtt

				 I = I + 1

				 Ali_Rn(I).D_A = CE.Address

				 Ali_Rn(I).V_A = CE.FormulaR1C1

		 Next CE

		 .Range(.Cells(a, 2).Address, .Cells(b, 250).Address).ClearContents

End With

For I = 1 To UBound(Ali_Rn)

Sh.Range(Ali_Rn(I).D_A).Offset(-1, 0).FormulaR1C1 = Ali_Rn(I).V_A

Next I

Sh.Range(Cells(6, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data"

Sn.Activate

		 .Calculation = xlCalculationAutomatic

		 .EnableEvents = True

		 .ScreenUpdating = True

		 End With

Application.CutCopyMode = False

Erase Ali_Rn

Set CE = Nothing: Set Rn = Nothing

Set R = Nothing: Set Rtt = Nothing

End With

End Sub

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

أم عبد الله

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

أخي الأستاذ الفاضل / عباد

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

أنا تعبت حضرتك جداً ولكن الكود الأخير مسح المعادلات في ورقة المنقولين وأما في ورقة البيانات لا يأخذ ترتيب الصفوف في نسخ المعادلات بمعنى لو وقفت على الخلية المكتوب فيها المعادلة بعد النقل تجدها بالترتيب التي كانت عليه وليس الترتيب الجديد. ولك جزيل الشكر.

إذا كان الأمر فيه صعوبة أرجو عمل كود واحد فقط وهو عندما اختار اسم الموظف في صفحة الريئسية المؤشر يقف في صفحة البيانات على اسم هذا الموظف ولك كل التقدير والاحترام.

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept