مشكوره جهودك استاذ ياسر العزير جعلها الله في ميزان حسناتك 

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

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

 Not Rows("1:3").Hidden = Rows("1:3").Hidden



كود الموضوع

 Option Explicit

Sub Export_Print_active_sheet()

Dim Sh As Worksheet, r As Range, F, Y, D, S As String, I As Integer

Set Sh = ActiveSheet

Application.ScreenUpdating = False

On Error Resume Next

    Set r = Sh.Range(Sh.PageSetup.PrintArea)

    F = "D:الارشيف"

    Y = F & "" & Format(Now(), "yyyy-MM") & ""

    D = Y & "" & Format(Now(), "yyyy-MM-DD") & ""

    On Error Resume Next

    MkDir F: MkDir Y: MkDir D

    r.CopyPicture xlScreen, xlPicture

    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Temp"

' السطر التالي للعداد

    I = 1: S = D & Dir(D): Do While S <> D: I = I + 1: S = D & Dir(): Loop

    With ActiveSheet

        .Shapes.AddChart.Select

        .Shapes("Chart 1").Width = r.Width: .Shapes("Chart 1").Height = r.Height

        With ActiveChart: .Paste

        .Export Filename:=D & "" & I & " " & Sh.Range("D6") & "      " & Format(Now(), "DD-MM-yyyy") & "." & "png", Filtername:="png"

        Sh.PrintOut Copies:=0, Collate:=True, IgnorePrintAreas:=False

        End With

    End With

Application.DisplayAlerts = False

    Sheets("Temp").Delete

    Application.GoTo Sh.Range("D6")

Application.DisplayAlerts = True

End Sub

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

 السلام عليكم هل يمكن اضافة هذه الاكواد لتسريع

Application.EnableEvents = False

Application.ScreenUpdating = False

Application.Calculation = xlManual



Application.EnableEvents = True

Application.ScreenUpdating = True

Application.Calculation = xlAutomatic


كود البحث للاستاذ سليم المحترم

Private Sub TextBox1_Change()

WSLR = WS.Cells(Rows.Count, 1).End(xlUp).Row

MOT = "*" & TextBox1.Value & "*"

If Len(MOT) <= 2 Then Exit Sub

If Me.ListBox1.ListIndex >= 0 Then Exit Sub

    With Me.ListBox1

        .Clear

        .ColumnCount = 4

     Set f_RG = WS.Range("B1:B" & WSLR).Find(MOT, LOOKAT:=1)

      If Not f_RG Is Nothing Then

        RO1 = f_RG.Row: RO2 = RO1

        Do

         .AddItem

         For K = 0 To .ColumnCount - 1

         .List(.ListCount - 1, K) = WS.Cells(RO2, 5 - K).Value

         Next

            Set f_RG = WS.Range("B1:B" & WSLR).FindNext(f_RG)

            RO2 = f_RG.Row

            If RO2 = RO1 Then Exit Do

        Loop

      End If

    End With

End Sub


كود الاستاذ حسونة المحترم

Private Sub TextBox1_Change()

WSLR = WS.Cells(Rows.Count, 1).End(xlUp).Row

K = 0

On Error Resume Next

    With Me.ListBox1

        .Clear

        .ColumnCount = 4

        For Each C In WS.Range("B2:B" & WSLR)

            If TextBox1.Value <> "" Then

                If C Like "*" & TextBox1.Value & "*" Then

                    .AddItem

                    .List(K, 0) = WS.Cells(C.Row, 5).Value

                    .List(K, 1) = WS.Cells(C.Row, 4).Value

                    .List(K, 2) = WS.Cells(C.Row, 3).Value

                    .List(K, 3) = WS.Cells(C.Row, 2).Value

                    .List(K, 4) = C.Row

                    K = K + 1

                End If

            End If

        Next C

    End With

End Sub

 الله يحفظكم ويبارك بيكم اساتذنا الاكارم بدون استثناء على جهودكم المبذولة في هذا المنتدى العظيم الله يجعلها في ميزان حسناتكم

 شكرا جزيلا على هذه المعلومات المفيده بارك الله بيك 

 للرفع

 استاذ سليم انا قصدي تغيير في طريقه العرض داخل التكست بوكس واعمده اليست بوك محتاج ان يكون الاسم الاول ضاهر واسم الجد غير ضاهر في حال تقليص حجم التكست بوكس او تقليص حجم اعمده اليست بوك  بعكس ماهو في المرفق . تحياتي لحضرتك 

 شكرا لك استاذ سليم العزيز 

لم ينجح الامر مع اليست بوك ١و٢

مثلا اضهار الاسم(جاسم) الاول واخفاء الاسم الثالث (سليم)مع جزيل الشكر

 الحمد لله انحل الموضوع عن طريق عمل نسخة للملف وتغيير موقعه اشكركم جميعا على مساعدتكم في حل المشكلة 

تحياتي للجميع 

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