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

[زوهير]

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

اولا بارك الله فيكم وجزاكم الله خير الجزاء على مساعدتكم لنا وزادكم الله علما

ثانيا اريد اكواد تقوم بعملية الترحيل من خلايا معينة الى جدول بدون تنسيقات ورقة العمل ودوالها

وفي المرفق توصيح اكثر

teste1.rar

[الـعيدروس]

هذا الكود للزر الاول

Private Sub CommandButton1_Click()

Dim sh As Worksheet

Set sh = Sheets(CommandButton1.Caption)

Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy

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

[E2:K3].ClearContents

Application.CutCopyMode = False

End Sub

وهذا للزر الثاني

Private Sub CommandButton2_Click()

Dim sh As Worksheet

Set sh = Sheets(CommandButton2.Caption)

Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy

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

[E2:K3].ClearContents

Application.CutCopyMode = False

End Sub

وهذا المرفق

T_ALI.rar

تم تعديل يناير 11, 2012 بواسطه alidroos

[احمدزمان]

اخي ابو نصار

ابداع × ابداع

كود احترافي جدا

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

بالذات Union هذه فكرة رائعة

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

ونقوم نحن باضافة التنسيق الى كود الترحيل

اما كود التصفية المتقدمة فهو الذي يقوم بنقل التنسيقات مع البيانات

مع التحية

[الـعيدروس]

جزاك الله خير استاذ احمد يعقوب

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

تقبل تحياتي وشكري

[زوهير]

بارك الله فيك وجزاك الله خيرا

فعلا ابداع ما بعده ابداع زادك الله علما وحفظك من كل مكروه

فعلا هذا هو المطلوب بالضبط *** ملاحظة فقط كيف يمكن زيادة تنسيق معين مثلا عند نقل المعطيات توضع داخل ايطار**

والله كل يوم يزداد تعلقنا بالمنتدى وبكل من فيه

والله تعلمت اشياء في غضون ايام لم اكن اتوقعها في عالم الاكسل ووفرت على نفسي كثيرا من الاعمال

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

تم تعديل يناير 11, 2012 بواسطه زوهير

[الـعيدروس]

مثل ماذا تسطير مثلا ؟؟

[زوهير]

مثلا ان يتم تسطير البيانات المرحلة

[الـعيدروس]

حط التنسيق المراد في خلية M2

واستبدل الاكواد السابقة بهذه

Private Sub CommandButton1_Click()

Dim sh As Worksheet

Set sh = Sheets(CommandButton1.Caption)

Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy

With sh

ALI = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

.Range("A" & ALI).PasteSpecial xlPasteValues

Range("M2").Copy

.Range(.Cells(ALI, 1), .Cells(ALI, 6)).PasteSpecial xlPasteFormats

Application.CutCopyMode = False

End With

[E2:K3].ClearContents

End Sub

Private Sub CommandButton2_Click()

Dim sh As Worksheet

Set sh = Sheets(CommandButton2.Caption)

Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy

With sh

ALI = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

.Range("A" & ALI).PasteSpecial xlPasteValues

Range("M2").Copy

.Range(.Cells(ALI, 1), .Cells(ALI, 6)).PasteSpecial xlPasteFormats

Application.CutCopyMode = False

End With

[E2:K3].ClearContents

End Sub

تم تعديل يناير 11, 2012 بواسطه alidroos

[زوهير]

بارك الله فيك اخي الكريم لقد نجح الامر

نعم هو المطلوب بذات

شكرا لك على هذه التلبية لطلب في اسرع وقت ولله تستاهل كل خير

[الـعيدروس]

الحمد لله

شكرا لك وجزاك الله على كلماتك الرقيقة

[زوهير]

ولله ليس مجاملة فعلا انتم لايبخلون علينا بما عندكم من علم في هذا الميدان

واستفدنا منكم الكثير مع اننا لم نقدم لكم سوى كلمات شكر

فتقبلوها منا

وهناك مثل يقول --- من علمني حرفا صرت له عبدا---

أحسِن إلى الناس تستعبد قلوبهم *** فطالما استعبد الإنسانَ إحسان