مساعده فى تقرير بشروط

Sub Test()

    Dim wsData As Worksheet, ws As Worksheet, sh As Worksheet, c As Range, m As Long, n As Long, r As Long, x As Long, col As Long

    

    Application.ScreenUpdating = False

        Set wsData = data0: Set ws = Sheet3: Set sh = sheet10

        

        sh.Range("B5:H" & Rows.Count).ClearContents

        m = ws.Cells(Rows.Count, 10).End(xlUp).Row

        If m < 5 Then Exit Sub

        

        For r = 5 To m

            If ws.Cells(r, 10).Value = sh.Range("D2") Then

                n = sh.Cells(Rows.Count, 4).End(xlUp).Row + 2: x = 0

                sh.Cells(n, 3).Value = ws.Cells(r, 5).Value

                sh.Cells(n, 4).Value = "مستخلص رقم " & ws.Cells(r, 5).Value

                sh.Cells(n + 1, 4).Resize(11).Value = wsData.Range("B5").Resize(11).Value

                

                sh.Cells(n, 5).Value = ws.Cells(r, 15).Value

                

                For Each c In sh.Range("D" & n + 1).Resize(11).Cells

                    x = x + 1

                    col = Choose(x, 17, 19, 21, 23, 25, 27, 29, 31, 32, 33, 34)

                    sh.Cells(c.Row, 6).Value = ws.Cells(r, col).Value

                Next c

            End If

        Next r

    Application.ScreenUpdating = True

    

    MsgBox "Done...", 64

End Sub