طلب مراجعة علي كود الاخفاء التالي

[DBA.Oracle]

    Dim i As Integer

for each worksheet in Workbook.Worksheet

    For i = 4 To 115

        If Range("B" & i).Value = 0 Then

            Rows(i & ":" & i).EntireRow.Hidden = True

        End If

    Next i

Next worksheet

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

لاجعله يخفي الصفوف الفارغة فى كل الصفحات المختارة

فلا اعلم المشكلة هل من الكود نفسه ام من عدم وضعه فى المكان الصحيح داخل كود ارسال رسائل متعددة بالايميل

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

[DBA.Oracle]

ودا كود الارسال

Sub Mail_Sheets_Array()

'Working in 2000-2010

    Dim FileExtStr As String

    Dim FileFormatNum As Long

    Dim Sourcewb As Workbook

    Dim Destwb As Workbook

    Dim TempFilePath As String

    Dim TempFileName As String

    Dim OutApp As Object

    Dim OutMail As Object

    Dim sh As Worksheet

    Dim TheActiveWindow As Window

    Dim TempWindow As Window


    With Application

        .ScreenUpdating = False

        .EnableEvents = False

    End With


    Set Sourcewb = ActiveWorkbook


    'Copy the sheets to a new workbook

    'We add a temporary Window to avoid the Copy problem

    'if there is a List or Table in one of the sheets and

    'if the sheets are grouped

    With Sourcewb

        Set TheActiveWindow = ActiveWindow

        Set TempWindow = .NewWindow

        .Sheets(Array("Sheet1", "Sheet3")).Copy

    End With


    'Close temporary Window

    TempWindow.Close


    Set Destwb = ActiveWorkbook


    'Determine the Excel version and file extension/format

    With Destwb

        If Val(Application.Version) < 12 Then

            'You use Excel 97-2003

            FileExtStr = ".xls": FileFormatNum = -4143

        Else

            'You use Excel 2007-2010, we exit the sub when your answer is

            'NO in the security dialog that you only see  when you copy

            'an sheet from a xlsm file with macro's disabled.

            If Sourcewb.Name = .Name Then

                With Application

                    .ScreenUpdating = True

                    .EnableEvents = True

                End With

                MsgBox "Your answer is NO in the security dialog"

                Exit Sub

            Else

                Select Case Sourcewb.FileFormat

                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51

                Case 52:

                    If .HasVBProject Then

                        FileExtStr = ".xlsm": FileFormatNum = 52

                    Else

                        FileExtStr = ".xlsx": FileFormatNum = 51

                    End If

                Case 56: FileExtStr = ".xls": FileFormatNum = 56

                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50

                End Select

            End If

        End If

    End With


    '    'Change all cells in the worksheets to values if you want

    '    For Each sh In Destwb.Worksheets

    '        sh.Select

    '        With sh.UsedRange

    '            .Cells.Copy

    '            .Cells.PasteSpecial xlPasteValues

    '            .Cells(1).Select

    '        End With

    '        Application.CutCopyMode = False

    '        Destwb.Worksheets(1).Select

    '    Next sh



    'Save the new workbook/Mail it/Delete it

    TempFilePath = Environ$("temp") & "\"

    TempFileName = "Part of " & Sourcewb.Name & " " _

                 & Format(Now, "dd-mmm-yy h-mm-ss")


    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)


    With Destwb

        .SaveAs TempFilePath & TempFileName & FileExtStr, _

                FileFormat:=FileFormatNum

        On Error Resume Next

        With OutMail

            .To = "ron@debruin.nl"

            .CC = ""

            .BCC = ""

            .Subject = "This is the Subject line"

            .Body = "Hi there"

            .Attachments.Add Destwb.FullName

            'You can add other files also like this

            '.Attachments.Add ("C:\test.txt")

            .Send   'or use .Display

        End With

        On Error GoTo 0

        .Close SaveChanges:=False

    End With


    'Delete the file you have send

    Kill TempFilePath & TempFileName & FileExtStr


    Set OutMail = Nothing

    Set OutApp = Nothing


    With Application

        .ScreenUpdating = True

        .EnableEvents = True

    End With

End Sub

[يحيى حسين]

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

أخي جرب عدل السطر الاول فقط

For Each Worksheet In ThisWorkbook.Worksheets

و أعلمني

[DBA.Oracle]

                 Dim i As Integer

                 For Each Worksheet In ThisWorkbook.Worksheets

    For i = 4 To 115

        If Range("B" & i).Value = 0 Then

            Rows(i & ":" & i).EntireRow.Hidden = True

        End If

    Next i

    Next Worksheet

يقوم بتنفيذ الامر علي الصفحة الاولي فقط من الصفحات المختارة

المفروض ان الكود يخليه لو انا اخترت 2 علشان يعملهم كوبي ويضعهم فى وورك شيت جديد ويعملهم مرفق فى رسالة ينفذ الكود علي الصفحتين وليس علي الاولي فقط فما الخطأ هنا ؟ :s

[DBA.Oracle]

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

    Dim i As Integer

   For i = 4 To 115

        If Range("B" & i).Value = 0 Then

        For Each Worksheet In ThisWorkbook.Worksheets

            Rows(i & ":" & i).EntireRow.Hidden = True

        Next Worksheet


End If

    Next i

[يحيى حسين]

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

أخي جرب هذا التعديل البسيط

 Dim i As Integer

             	For Each Worksheet In ThisWorkbook.Worksheets

	For i = 4 To 115

    	If Worksheet.Range("B" & i).Value = 0 Then

        	Worksheet.Rows(i & ":" & i).EntireRow.Hidden = True

    	End If

	Next i

	Next Worksheet

و لو تقوم بتعريف متغير يكون افضل في التعامل و اريح لك بحيث يصبح الكود كما يلي :

 

Dim i As Integer, ws As Worksheet

             	For Each ws In ThisWorkbook.Worksheets

	For i = 4 To 115

    	If ws.Range("B" & i).Value = 0 Then

        	ws.Rows(i & ":" & i).EntireRow.Hidden = True

    	End If

	Next i

	Next ws

 

[DBA.Oracle]

اخي الفاضل / يحي

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

[يحيى حسين]

حياك الله أخي

و نحن في الخدمة

جزاك الله كل خير على كلامك الطيب

[DBA.Oracle]

اخي يحي ااسف مرة اخري لكن هناك شيء بسيط بعد اذنك

الكود بعد تعديلك له يعمل ممتاز

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

Set Destwb = ActiveWorkbook

Dim i As Integer, sh As Worksheet

   For Each sh In Destwb.Worksheets

        For i = 4 To 115

        If sh.Range("B" & i).Value = 0 Then

                sh.Rows(i & ":" & i).EntireRow.Hidden = True

        End If

        Next i


        sh.Select

            With sh.UsedRange

                .Cells.copy

               .Cells.PasteSpecial xlPasteValues

                .Cells(1).Select

           End With

           Application.CutCopyMode = False

            Destwb.Worksheets(1).Select

        Next sh

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

[DBA.Oracle]

 Dim i As Integer, sh As Worksheet

   For Each sh In Destwb.Worksheets

        For i = 4 To 115

        If sh.Range("B" & i).Value = 0 Then

                sh.Rows(i & ":" & i).EntireRow.Hidden = True

        End If

        Next i

                Next sh

   For Each sh In Destwb.Worksheets

        sh.Select

            With sh.UsedRange

                .Cells.copy

               .Cells.PasteSpecial xlPasteValues

                .Cells(1).Select

           End With

           Application.CutCopyMode = False

            Destwb.Worksheets(1).Select

        Next sh

هكذا يعمل الكود فصلت الاثنين عن بعضهما

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

لك فائق الشكر والتقدير

[يحيى حسين]

أخي جربت كودك و اشتغل معي بشكل صحيح

و لكني

إستبدل ActiveWorkbook

و ضع مكانها

ThisWorkbook

سيكون افضل للكود

رغم ان الكود معي تمام و لم اواجه اي مشاكل

[DBA.Oracle]

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

لك جزيل الشكر

[يحيى حسين]

أخي بدون فصل

لقد عمل معي بشكل صحيح بدون فصلهما

[abo mohamad]

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

لك جزيل الشكر

اخوانى الكرام كيف تتم كتابة هذه الاكواد الرائعه ؟ واين تعلمتموها؟ ومن اين نبدا فى تعلمها ؟ افيدونا يرحمكم الله