| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):Excel 2013
* 아래줄에 질문을 작성하세요 >>
※ 다음과 같은 방법으로 순위표를 만들려고 합니다.
1. "클리커"SHEET에 각 심판별 점수를 입력합니다.
2. 자동으로 "채점표"SHEET에 채점이 나옵니다.
3. 자동으로 "순위표"SHEET에 순위별로 참가번호와 참가자 이름등 점수를 정렬해서 보여주고자 합니다.
4. 동점자가 발생하였을 경우 순위표에 자동으로 동순위 표시를 하고 참자가를 불러오고 싶습니다.
5. 오름차순 정렬을 사용해서 채점표를 복사해서 붙여넣기 후 오를차순 정렬을 하는 방법이 아닌 자동으로 순위표를 만들고자 합니다.
★ 도와 주시면 무척 감사하겠습니다~~ ^-^;;
==============[샘물님 글에 대한 답변입니다]==============
VBA로 만들었습니다. 첨부화일 참고하세요...
Sub GetResult()
Dim wst As Worksheet, wstTg As Worksheet
Dim rData As Range, rItem As Range
Dim rFind As Range, rWhat As Range
Dim iX As Integer, iSplitRow As Integer, iSplitColumn As Integer
Const sTitle As String = "▣ 대회 순위별 점수"
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set wst = Worksheets("채점표")
wst.Calculate
wst.Activate
Set rData = wst.Range("A1").CurrentRegion
Set rItem = wst.Columns("J").SpecialCells(xlCellTypeConstants, 23)
With ActiveWindow
iSplitRow = .SplitRow + 1
iSplitColumn = .SplitColumn + 1
End With
On Error Resume Next
Worksheets("순위표").Delete
Set wstTg = Worksheets.Add(Before:=wst)
wstTg.Name = "순위표"
On Error GoTo 0
rData.Copy
With wstTg.Range("A1")
.PasteSpecial Paste:=xlPasteValues ' 값
.PasteSpecial Paste:=xlPasteFormats ' 서식
.PasteSpecial Paste:=xlPasteColumnWidths ' 열너비
Application.CutCopyMode = False
wstTg.Cells.FormatConditions.Delete
For iX = 1 To rData.Rows.Count ' 행높일
.CurrentRegion.Rows(iX).RowHeight = rData.Rows(iX).Height
Set rWhat = rData.Cells(iX, 4)
If rWhat.Value <> "" Then
Set rFind = rItem.Find(rWhat.Value, LookAt:=xlWhole)
If Not rFind Is Nothing Then
rWhat.Font.Color = rFind.Font.Color
End If
End If
Next
.Value = sTitle
.Cells(iSplitRow, iSplitColumn).Select
With ActiveWindow
.DisplayGridlines = False
.FreezePanes = True
End With
' 정렬
With .CurrentRegion
With .Offset(1).Resize(.Rows.Count - 1)
'.Sort Key1:="순위", Key2:="참가" & vbLf & "번호", Header:=xlYes
.Sort Key1:=.Cells(1, 1), Key2:=.Cells(1, 2), Header:=xlYes
End With
End With
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
|
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
