К сожалению полностью разобраться не удалось, завтра, послезавтра последний день сдачи начальству:) нашел ссылку по VBA http://www.on-line-teaching.com/vba/lsn0116.html со сл. недели только начну его изучение с самого начала, если не сложно помогите пожалуйста справится с этой задачей:) буду очень признателен.

Кстати, а где оценки в карточке?  
Одна, обе, или как? И какую брать, если две?

Ну оценки не известны пока, при выборе из выплывающего списка оценки он должен вставлять ее как нужно на лист "приложения"    
 
Я вот код этот попробовал поставить, нечего не получилось:( либо не аботает либо ссылается на Private Sub CommandButton2_Click()

Сам вот щас думаю насчет того чтобы заполнение шло опять же с "плана"но это не желательно:) так как там оценок не будет.  
 
Взял за основу вами написанный код ранее, ну %60 его не понимаю и в связи с этим нечего толкового не выходит.  
 
Private Sub CommandButton1_Click()  
Dim a(), i As Byte, ii As Long, iii As Long, x As Byte  
Dim oDict As Object, cs As Double  
 
Set oDict = CreateObject("Scripting.Dictionary")  
oDict.CompareMode = vbTextCompare  
 
a = Sheets("План").UsedRange.Value  
 
 
For i = 8 To 67 Step 10  
ReDim b(1 To 59, 1 To 1)  
ReDim bb(1 To 59, 1 To 1)  
iii = 0  
x = x + 1  
For ii = 6 To UBound(a)  
If Len(a(ii, 68)) > 0 Then  
 
iii = iii + 1  
b(iii, 1) = a(ii, 2)  
 
'=====================  
cs = a(ii, 7)  
If cs <> Fix(cs) Then  
 
oDict.Item(Trim(a(ii, 2))) = oDict.Item(Trim(a(ii, 2))) + 1  
 
'последний  
bb(iii, 1) = a(ii, 7) - Fix(cs) * (oDict.Item(Trim(a(ii, 2))) - 1)  
Else  
'не последний  
bb(iii, 1) = Fix(cs)  
End If  
 
Else  
bb(iii, 1) = cs  
End If  
'=====================  
 
 
 
Next  
Cells(i, 2).Resize(59, 1) = b  
Cells(i, 3).Resize(59, 1) = bb  
Next  
 
For i = 79 To 137 Step 10  
ReDim b(1 To 59, 1 To 1)  
ReDim bb(1 To 59, 1 To 1)  
iii = 0  
x = x + 1  
For ii = 6 To UBound(a)  
If Len(a(ii, 68)) > 0 Then  
 
iii = iii + 1  
b(iii, 1) = a(ii, 2)  
 
'=====================  
cs = a(ii, 7)  
If cs <> Fix(cs) Then  
 
oDict.Item(Trim(a(ii, 2))) = oDict.Item(Trim(a(ii, 2))) + 1  
 
'последний  
bb(iii, 1) = a(ii, 7) - Fix(cs) * (oDict.Item(Trim(a(ii, 2))) - 1)  
Else  
'не последний  
bb(iii, 1) = Fix(cs)  
End If  
 
Else  
bb(iii, 1) = cs  
End If  
'=====================  
 
 
 
Next  
Cells(i, 2).Resize(59, 1) = b  
Cells(i, 3).Resize(59, 1) = bb  
Next  
 
 
End Sub  
 
 
Работает он ужасно, в столбик огромное количество дисциплин пишет с их же повторением.  
 
Помогите пожалуйста с каким нибудь их двух вариантов:) какой будет по проще:) если первым то хорошо:) если тем что я щас пытаюсь пол дня и ночи сделать но пускай уж сами руками оценки выставляют и в "карте" и в "Приложении":)

60% - это много... Тогда попробуйте понять последний код, от 18.04.2012, 23:50  
Там используется всего лишь цикл, массивы (один из данных диапазона и один созданный в коде - используется в паре с словарём), словарь, проверки на длину строки и на число.  
Ну и выгрузка массива потом ниже отдельно дописана.  
 
Про кнопку: была мысль добавить код на кнопку - но я не нашёл подходящей, поэтому написал код без привязки к кнопке.  
Можете сами всё, что между Sub to_pril() и  End Sub скопировать в код любой кнопки.  
Или же в коде кнопки написать одну строку:    
to_pril  
А код как есть поместить в стандартный модуль (там как раз один пустой заготовлен, хотя код можно добавить в любой модуль).  
 
Ну и перед проверкой работы - очистите место выгрузки (или добавьте этот функционал в начало кода, там что-то похожее помнится уже где-то есть), иначе можете не заметить результат работы.  
 
Пример кода за 19.04.2012, 02:52 сейчас проверить не на чем, так что не прокомментирую. Детали исходного кода уже не помню.

Ну давайте опять свой файл куда-нить на обменник или мне на мыло (внизу замаскировано) - посмотрю.  
Только что-то мыло испортилось - мигрировало на яндекс и работает сегодня никак... кое-как...

Так Вы сразу из "плана" хотите заполнить "приложение"? Вероятно можно и так, но разбираться сейчас неохота и некогда.  
Я код написал для импорта данных из листа "Карточка" там уже будут проставлены оценки, вот оттуда и берём данные сразу с оценками (из поля "за экзамен")  
Добавил очистку листа, обработку ошибки если нечего выгружать, и выгрузку на оба листа формы (может можно сделать элегантнее, но работает и так):  
 
Private Sub CommandButton1_Click()  
   Dim a(), i&, ii&, t$, n&  
 
   a = Sheets("Карточка").UsedRange.Value  
   ReDim b(1 To UBound(a), 1 To 3)  
 
   With CreateObject("Scripting.Dictionary")  
       .CompareMode = 1  
       For i = 1 To UBound(a)  
           t = a(i, 3)  
           If Len(t) Then  
               If Len(a(i, 13)) Then  
                   If IsNumeric(a(i, 13)) Then  
                       If Not .exists(t) Then  
                           ii = ii + 1  
                           .Item(t) = ii  
                           b(ii, 1) = t  
                           b(ii, 2) = a(i, 13)  
                           b(ii, 3) = a(i, 14)  
                       Else  
                           n = .Item(t)  
                           b(n, 2) = b(n, 2) + a(i, 13)  
                           b(n, 3) = a(i, 14)  
                       End If  
                   End If  
               End If  
           End If  
       Next  
 
   End With  
 
   If ii > 0 Then  
   Sheets(3).UsedRange.ClearContents  
       Sheets(3).[b8].Resize(60, 3) = b
       If ii > 60 Then  
           For i = 60 To ii  
               Cells(i + 19, 2) = b(i, 1)  
               Cells(i + 19, 3) = b(i, 2)  
               Cells(i + 19, 4) = b(i, 3)  
           Next  
       End If  
   End If  
End Sub

For i = 61 To ii  
хардкор!  
http://lurkmore.to/%2B%2Bi_%2B_%2B%2Bi