كود الترحيل حسب قيم مختلفة

Sub Test()

    Dim x, ws As Worksheet, sh As Worksheet, sGrade As String, iMark As Integer, m As Long, r As Long, c As Long, cl As Long

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("BD")

    Set sh = ThisWorkbook.Worksheets("CV")

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

    For r = 3 To m

        x = Application.Match(ws.Cells(r, 1).Value, sh.Columns(1), 0)

        If IsError(x) Then GoTo Skipper

        sh.Range("C" & x + 1).Resize(10, 4).ClearContents

        For c = 2 To 11

            sGrade = ws.Cells(r, c).Value

            Select Case sGrade

                Case "A": iMark = 8: cl = 3

                Case "B": iMark = 7: cl = 4

                Case "C": iMark = 4: cl = 5

                Case "D": iMark = 1: cl = 6

                Case Else: GoTo nextV

            End Select

            sh.Cells(x + c - 1, cl).Value = iMark

nextV:

        Next c

Skipper:

    Next r

    Application.ScreenUpdating = True

    MsgBox "Done", 64, "YasserKhalil Excel-Egy"

End Sub

Case "A": iMark = 8: cl = 3

                Case "B": iMark = 7: cl = 4

                Case "C": iMark = 4: cl = 5

                Case "D": iMark = 1: cl = 6

Case "A": iMark = 8