부동산 실거래가 자료를 기록하기 시작했습니다. 버전이 2007이다 보니 동적 레전드 기능이 안되서 vba로 작성했습니다. 생각나는대로 기능위주로 만들다보니 Module화랑 Interface가 빈약한 점은 추후 개선해보도록 하겠습니다. 파일은 주요 아파트가 기록이 되어있기에 삭제되는대로 첨부하겠습니다.
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2021-03-25 Initial Release
' **************************************************************************
'Force the explicit declaration of variables
Option Explicit
Sub add_Click()
Call add '계열 추가 호출
End Sub
Sub del_Click()
Call del '계열 삭제 호출
End Sub
Sub copy_Click()
Call copyRange '범위 복사 호출
End Sub
Sub copyNm_Click()
Call copyNm '이름 복사 호출
End Sub
Sub init_Click()
Call initialize '초기화 호출
End Sub
Sub sort_Click()
Call sortRoi '수익률 정렬
End Sub
'계열 추가
Private Sub add()
'ActiveChart.PlotArea.Select
If ActiveChart Is Nothing Then
MsgBox "차트를 선택해주세요", vbExclamation, "Chart"
Exit Sub
Else
End If
Dim lngSerCnt, lngLastRow As Long
Dim strDel As String
Dim strAddSrs As String
lngSerCnt = ActiveChart.SeriesCollection.Count + 1
strDel = Trim(ActiveSheet.OLEObjects("txtDel").Object.Text)
'strDel = Replace(strDel, Chr(10), "") 'vbLf
'strDel = Replace(strDel, Chr(13), "") 'vbCr
If strDel = "" Then
MsgBox "추가할 계열명을 입력해주세요", vbExclamation, "Chart"
Exit Sub
End If
strAddSrs = Trim(ActiveSheet.OLEObjects("txtAddSrs").Object.Text)
If strAddSrs = "" Then
MsgBox "계열범위를 복사해주세요", vbExclamation, "Chart"
Exit Sub
End If
'lngLastRow = Cells(1, 1).End(xlDown).Row
'MsgBox lngLastRow
Application.ScreenUpdating = False
ActiveChart.SeriesCollection.NewSeries
'ActiveChart.SeriesCollection(lngSerCnt).Name = "=서울!$D$2"
ActiveChart.SeriesCollection(lngSerCnt).Name = strDel
'ActiveChart.SeriesCollection(lngSerCnt).Values = "=서울!$D$3:$D$22"
ActiveChart.SeriesCollection(lngSerCnt).Values = "=서울!" & strAddSrs & ""
'Call initialize '초기화 호출
Application.ScreenUpdating = True
End Sub
'계열 삭제
Private Sub del()
'Declare the variables
Dim lngSerCnt As Long
Dim strDel As String
'ActiveChart.PlotArea.Select
If ActiveChart Is Nothing Then
MsgBox "차트를 선택해주세요", vbExclamation, "Chart"
Exit Sub
Else
End If
'MsgBox ActiveSheet.OLEObjects("txtDel").Object.Value, vbExclamation, "Chart"
strDel = Trim(ActiveSheet.OLEObjects("txtDel").Object.Text)
strDel = Replace(strDel, Chr(10), "") 'vbLf
strDel = Replace(strDel, Chr(13), "") 'vbCr
strDel = Trim(strDel)
'MsgBox strDel, vbExclamation, "Chart"
If strDel = "" Then
MsgBox "삭제할 계열명을 입력해주세요", vbExclamation, "Chart"
Exit Sub
End If
Application.ScreenUpdating = False
With ActiveChart
DoEvents
For lngSerCnt = .SeriesCollection.Count To 1 Step -1
If .SeriesCollection(lngSerCnt).Name = strDel Then .SeriesCollection(lngSerCnt).Delete
Next lngSerCnt
End With
Call initialize '초기화 호출
Application.ScreenUpdating = True
End Sub
'초기화
Private Sub initialize()
ActiveSheet.OLEObjects("txtDel").Object.Text = ""
ActiveSheet.OLEObjects("txtAddSrs").Object.Text = ""
End Sub
'이름 복사
Private Sub copyNm()
Dim strSelRng As String 'Selection.Address
If ActiveChart Is Nothing Then
strSelRng = Selection.Text
If strSelRng = "" Then
MsgBox "선택하신 계열명이 공백입니다.", vbExclamation, "Chart"
ActiveSheet.OLEObjects("txtDel").Object.Text = ""
Exit Sub
End If
ActiveSheet.OLEObjects("txtDel").Object.Text = strSelRng
Else
MsgBox "계열명을 선택해주세요", vbExclamation, "Chart"
ActiveSheet.OLEObjects("txtDel").Object.Text = ""
Exit Sub
End If
End Sub
'범위 복사
Private Sub copyRange()
'Range("서울").CurrentRegion.Copy
Dim strSelRng As String 'Selection.Address
If ActiveChart Is Nothing Then
strSelRng = Selection.Address
ActiveSheet.OLEObjects("txtAddSrs").Object.Text = strSelRng
Else
MsgBox "복사할 범위를 선택해주세요", vbExclamation, "Chart"
ActiveSheet.OLEObjects("txtAddSrs").Object.Text = ""
Exit Sub
End If
End Sub
'수익률 정렬
Private Sub sortRoi()
Dim strSelCell As String '선택셀
Dim LastRow As Long
Dim rngSort As Range '정렬범위
strSelCell = ActiveCell.Address
Worksheets("ROI").Range("A1").EntireColumn.EntireRow.Clear 'Sheet(ROI) 초기화
'Copy
Worksheets("서울").Range("A2").EntireRow.Select
Selection.Copy
Sheets("ROI").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Worksheets("서울").Activate
Worksheets("서울").Range(strSelCell).EntireRow.Select
Selection.Copy
Sheets("ROI").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'Delete empty rows
Columns("B").SpecialCells(4).EntireRow.Delete
Columns("A:A").EntireColumn.AutoFit
Range(Range("A1", "B1"), Range("A1:B1").End(xlDown)).Select
Set rngSort = Selection
ActiveWorkbook.Worksheets("ROI").Sort.SortFields.Clear
'ActiveWorkbook.Worksheets("ROI").Sort.SortFields.add Key:=Range("B2:B11"),
ActiveWorkbook.Worksheets("ROI").Sort.SortFields.add Key:=Range("B2", Range("B2").End(xlDown)), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ROI").Sort
'.SetRange Range("A1:B11")
.SetRange rngSort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'cell형식: 비율
Range("B2", Range("B2").End(xlDown)).Select
Selection.Style = "Percent"
'테두리
rngSort.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'제목 가운데 정렬
Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
End Sub
'SI개발 > VBA' 카테고리의 다른 글
[VBA] Format Yahoo Fantasy Players List (0) | 2023.02.03 |
---|---|
[VBA]디렉토리 안의 파일 목록 구하기2 (0) | 2022.12.11 |
[VBA]디렉토리 안의 파일 목록 구하기 (0) | 2017.10.28 |
[VBA] 엑셀 디아블로2 my log(엑셀), jimmy's log(본문) (0) | 2016.03.27 |
[VBA]Excel. DB칼럼명을 Camel, pascal로 변환 (0) | 2016.03.26 |