표를 달력으로 보내기

거대 프로젝트. 표를 달력으로 보내는 프로젝트.

혼자 사용하는 파일이 아니라 옆자리 서무와 함께 써야하는 파일이라서

파일을 갱신만 하되 기존 파일은 손대지 않는 것이 포인트

달력은 내 파일과 서무파일의 일정이 합쳐서 나온다.

주소 및 연락처, 공문번호는 메모로 나타나게 된다.

이 내용을 별도의 표로 만들어주는 매크로까지.

2주동안 고민하고 또 고민해서 만든 파일.

소중하다.

Sub chK()
    Dim newBook As Workbook, oldBook As Workbook    '달력파일, 대상물 파일
    Dim rngCell As Range, rngDate As Range  '시정보완일정 영역
    Dim rngArea As Range    '전체 데이터 영역
    Dim rngD As Date    '시정보완일정
    Dim dtArr() As String, jnArr() As String    '대상물 배열, 달력에 있는 대상물 배열
    Dim chkDate As Range    '달력에 있는 보완 확인일자
    Dim i As Integer, j As Integer, k As Integer    '막쓰는 변수
    Dim ncV As Variant, nC As New Collection    '중복값 제거할 컬렉션
    Dim jnNC As String  '대상명을 모은 변수(달력에 실제로 표시됨)
    Dim arrAdd() As String, arrMemo() As String '메모에 넣을 배열, 기존 메모값 배열
    Dim jnAdd As String    '주소 연락처 Join
    Dim intLen As Integer, intName As Integer   '대상물 글자길이, 대상물 위치
    Dim strName As String    '메모에 넣을 대상명(종합이냐 작동이냐 구분)
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    '워크북, 작업영역 설정
    Set oldBook = ThisWorkbook
    Workbooks.Open Filename:=oldBook.Path & "\일정.xlsm"
    Set newBook = ActiveWorkbook
    oldBook.Activate
    
    '데이터 전체영역 및 시정보완일자 영역
    Set rngArea = Range("A3", Cells(Rows.Count, "A").End(xlUp)).Resize(, 23)
    Set rngDate = rngArea.Columns(20)
    
    '보완일자 기준으로 오름차순 정렬
    rngArea.Sort Key1:=Range("T3"), Order1:=xlAscending
        
    '보완일자를 순환하며 대상명을 배열에 추가
    i = 1
    For Each rngCell In rngDate.SpecialCells(2)
        rngD = rngCell
        Set chkDate = newBook.Sheets(Month(rngD) + 1).UsedRange.Find(What:=Day(rngD), lookat:=xlWhole).Offset(1)
            
        ReDim Preserve dtArr(1 To i)
        dtArr(i) = rngCell.Offset(, -18)
        
        '종합대상 및 확인완료대상 표시
        If Len(rngCell.Offset(, 1)) Then dtArr(i) = "√" & dtArr(i)
        If Len(rngCell.Offset(, 2)) Then dtArr(i) = dtArr(i) & "(종합)"
            
        '보완일자가 밑의 날짜와 같으면 배열 추가
        If rngCell = rngCell.Offset(1) Then
            i = i + 1
                
        '보완일자가 밑의 날짜와 다르면
        Else
                
            '달력에 기존 보완일자가 있을 때 데이터를 배열에 넣음
            If Len(chkDate) Then
                jnArr = Split(chkDate, Chr(10))
                
                '배열에 넣은 데이터를 보완일자를 순환하며 얻은 대상명과 합침
                For j = UBound(dtArr) + 1 To UBound(dtArr) + UBound(jnArr) + 1
                    ReDim Preserve dtArr(1 To j)
                    dtArr(j) = jnArr(k)
                    k = k + 1
                Next j
                    
                '중복된 대상명 제거
                For Each ncV In dtArr
                    On Error Resume Next
                        nC.Add Item:=ncV, Key:=CStr(ncV)
                    On Error GoTo 0
                Next ncV
                    
                For k = 1 To nC.Count
                    ReDim Preserve dtArr(1 To k)
                    dtArr(k) = nC(k)
                Next k
            End If
            jnNC = Chr(10) & Join(dtArr, Chr(10))
            
            '대상명을 순환하며 주소 및 연락처를 배열에 삽입(메모용)
            j = 1
            Set nC = Nothing
            ReDim arrAdd(1 To i)
            For k = i To 1 Step -1
                With rngCell
                    If Len(.Offset(1 - k, -17)) Then
                        
                        '작동, 종합 구분지어서 대상명에 입력
                        Select Case Len(.Offset(1 - k, 2))
                            Case Is > 0: strName = .Offset(1 - k, -18) & "(종합)"
                            Case 0: strName = .Offset(1 - k, -18) & "(작동)"
                        End Select
                        
                        arrAdd(j) = strName & " : " & .Offset(1 - k, -17) & ", " & .Offset(1 - k, -8) & ", " & .Offset(1 - k, 3) '대상명 : 주소, 연락처, 공문번호
                        j = j + 1
                    End If
                End With
            Next k
            
            '기존 메모를 배열에 넣음
            k = 0
            If Not chkDate.Comment Is Nothing Then
                arrMemo = Split(chkDate.Comment.Text, Chr(10) & Chr(10))
                
                '배열에 넣은 메모에서 중복값 제거
                For j = UBound(arrAdd) + 1 To UBound(arrAdd) + UBound(arrMemo) + 1
                    ReDim Preserve arrAdd(1 To j)
                    arrAdd(j) = arrMemo(k)
                    k = k + 1
                Next j
            
                '중복된 메모 제거
                For Each ncV In arrAdd
                    On Error Resume Next
                        nC.Add Item:=ncV, Key:=CStr(ncV)
                    On Error GoTo 0
                Next ncV
                                
                For k = 1 To nC.Count
                    ReDim Preserve arrAdd(1 To k)
                    arrAdd(k) = nC(k)
                Next k
            End If
            jnAdd = Join(arrAdd, Chr(10) & Chr(10))
            
            With chkDate
                .Value = jnNC
                .Font.Size = 9
                                    
                '주소, 연락처를 가져와 달력에 메모로 삽입
                On Error Resume Next
                    .AddComment
                On Error GoTo 0
                With .Comment
                    .Text Text:=jnAdd
                    .Shape.TextFrame.AutoSize = True
                    .Visible = False
                End With
                
                '완료대상에 취소선 긋기
                For i = 1 To UBound(dtArr)
                    If Left(dtArr(i), 1) = "√" Then    '확인완료대상일 때
                        intLen = Len(dtArr(i))
                        intName = InStr(chkDate, dtArr(i))
                        With .Characters(intName, intLen).Font
                            .Color = RGB(150, 150, 150): .Strikethrough = True
                        End With
                    End If
                Next i
            End With
            
            '변수 재사용을 위해 초기화
            Set nC = Nothing
            Erase dtArr: Erase jnArr: Erase arrAdd: Erase arrMemo
            k = 0
            i = 1
        End If
    Next rngCell
    
    '번호순으로 오름차순 정렬
    rngArea.Sort Key1:=Range("A3"), Order1:=xlAscending
    
    '달력파일 행높이 조절
    For i = 2 To 13
        newBook.Sheets(i).Range("A3:G13").EntireRow.AutoFit
    Next i
    newBook.Activate
    Sheets(Month(Now) + 1).Activate
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

+ 일정 원본 파일 +

+ 표의 데이터를 기반으로 달력이 만들어짐 +