Программа тестирования

Private Sub but_Click()
    Dim i&, j&, s$
    Dim maxResult&, cnt&
    'Достаем код из 6 колонки текущей строчки проверки
    s = Mid$(sh.Cells(CurRow, 6).Value, 2)
    'Получаем подсчет едениц. это будет максимальный результат для данного вопроса
    maxResult = Len(Replace(s, "0", ""))
    
    'Сравниваем есть ли совпадения в чекбоксах и коде
    For i = 1 To 4
        j = Abs(Controls("ch" & i).Value)
        
        If Mid$(s, i, 1) = j And j = 1 Then
            cnt = cnt + 1
        End If
        
    Next
    
    'Вычисляем максимальный балл который может быть равен 1
    CurResult = CurResult + cnt / maxResult
    
    Controls("lb2").Caption = "Результат в баллах: " & CurResult
    
    If CurRow >= MaxRow Then
        'Выход при окончании вопросов
        MsgBox "Тест завершен ваш результат = " & CurResult & " из максимально возможного " & MaxRow
        End
    End If
 
    Call NextQuestion
    
End Sub

' вместо
s = Mid$(sh.Cells(CurRow, 6).Value, 2)
' пишете
s = sh.Cells(CurRow, 6).Value
' а это:
If Mid$(s, i, 1) = j And j = 1 Then
     cnt = cnt + 1
End If
' заменяете этим:
If s = j And j = 1 Then
     cnt = cnt + 1
End If
' Там ещё сааамую малость осталось до вашей мечты :)

Public Type MyColor
    R As Byte
    G As Byte
    B As Byte
End Type

    f.R = 208
    f.G = 212
    f.B = 200

Sub g()
 With Sheets("Лист1")
    A = .Range(" A7").End(xlDown).Row
 
    .Range(.Cells(A + 1, 2), .Cells(A + 1, 5)).Merge
    .Cells(A + 1, 2) = "jhkjghk"
    .Range(.Cells(A + 1, 6), .Cells(A + 1, 8)).Merge
    .Range(.Cells(A + 1, 1), .Cells(A + 1, 9)).Borders.Weight = xlThin
    .Rows(A + 1 & ":" & A + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Cells(A, 1) = 1
        End With
End Sub

Rows(3).Insert