부동산 실거래가 자료를 기록하기 시작했습니다. 버전이 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

글 보관함

카운터

Total : / Today : / Yesterday :
get rsstistory!