|
老师们,可以指点一下,我这个怎么修改代码吗?
因为不是很明白,
依据样本创建评价表,VBA代码
http://club.excelhome.net/thread-1571605-1-1.html
(出处: ExcelHome技术论坛)
Sub lqh()
Dim arr, wb As Worksheet, Samp As Worksheet, d
Set wb = Sheets("学生情况")
Set Samp = Sheets("样本")
Set d = CreateObject("scripting.dictionary")
arr = wb.Range("A2:Y" & wb.[A1048576].End(3).Row)
Application.ScreenUpdating = False
For Each sht In Sheets
If sht.Name <> wb.Name And sht.Name <> Samp.Name Then sht.Delete
Next
For i = 2 To UBound(arr)
Samp.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = arr(i, 3)
[b3] = arr(i, 1): [b4] = arr(i, 3)
[d3] = arr(i, 2): [d4] = arr(i, 4)
For j = 1 To 4
Cells(5, j + 1) = arr(1, j + 4) & " " & arr(i, j + 4) & " 节"
Cells(13 + j, 2) = arr(i, 21 + j)
Next j
For j = 9 To 21
d(arr(1, j)) = arr(i, j)
Next j
For j = 7 To 13
If Cells(j, 2) <> "" Then Cells(j, 3) = d(Cells(j, 2).Value)
If Cells(j, 3) = "" Then
Cells(j, 3).Borders(xlDiagonalUp).LineStyle = xlContinuous
Else
Cells(j, 3).Borders(xlDiagonalUp).LineStyle = xlNone
End If
If Cells(j, 4) <> "" Then Cells(j, 5) = d(Cells(j, 4).Value)
If Cells(j, 5) = "" Then
Cells(j, 5).Borders(xlDiagonalUp).LineStyle = xlContinuous
Else
Cells(j, 5).Borders(xlDiagonalUp).LineStyle = xlNone
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
|
|