علي بن علي

استاذي الفاضل محمد

الكود يعمل بطالطريقة المطلوبه

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

تختفي بقية الاعمده الغير مطلوبه

المطلوب استاذي الفاضل

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

استاذي الفاضل سوف ارفق لك ملفين

للفكره التي اطلبها

وارجو ان يطبق ما فيها على الشيت الخاص بي

وانا اطلب طباعة الاعمده المحدده

وليس الصفوف

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

الملفات المرفقهطباعة اعمدة محددة مع صفوف اعتمادا على قيمة نصية+111.xlsb (1).rarطباعة اعمدة محددة مع صفوف اعتمادا على قيمة نصية+111.xlsb.rar

استاذي الفاضل محمد

المطلوب طباعة الاعمده الصفراء فقط

المظلله في الجدول فقط

حيث عند الضغط على زر المعاينه تظهر للطباعة الاعمده الصفراء فقط

وعند الخروج من المعاينه

تظهر جميع الاعمده كما كانت قبل الطباعه

والمشكله اني لا اريد اخفاء الاعمده

اريدها كلها ظاهره

وعند الطباعه فقط تظهر الاعمده الصفراء

وعند الخروج من المعاينه والطباعه

تظهر جميع الاعمده كما كانت . بدون اخفاء للأعمدة

اساتذتنا الكرام

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

ارفع اليكم هذا الشيت وارجو المساعده بطباعة اعمده محدده

بقية الشرح والتوضيح للمطلوب  داخل الشيت

طباعة اعمده محدده.xlsx

السلام عليكم وبها نبدأ

للخبراء 

تعديل هذا الكود في الملف المرفق

ولكن بشرط عند الترحيل 

لا ينسخ المعادلات الى الشيت الجديد المرحل اليه

بمعنى أوضح يرحل القيم فقط

ودمتم بخير وعافيه 

مرفق ملف به الكود كاملا

HOUS()
Dim sh As Worksheet
Dim nm
Dim x, lr
Dim arr
Dim ws As Worksheet: Set ws = Sheets(" 8")
Application.ScreenUpdating = False
x = InputBox("ÇÏÎá ÇÓã ÇáÔíÊ ÇáÐí ÓíÖÇÝ")

If x = "" Then MsgBox "ÇÏÎá ÇÓã ÇáÔíÊ ÇæáÇ", vbExclamation: Exit Sub
For Each sh In Sheets
If x = sh.Name Then
MsgBox "åÐÇ ÇáÇÏÎÇá ãæÌæÏ Öãä ÇÓãÇÁ ÇáÔíÊÇÊ", vbExclamation
Exit Sub
End If
Next sh
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = (x)
           Set nm = Sheets(x)
           nm.DisplayRightToLeft = True
           Sheets("Data").Range("B1:af1").Copy
           nm.Range("B1").PasteSpecial
           nm.Range("B1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
           SkipBlanks:=False, Transpose:=False
           Application.CutCopyMode = False
 lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
 ws.Range("B1:af" & lr).Copy nm.Range("B1")

الرجاء المساعده (1).xlsm