🧨 엑셀 VBA / 코딩 모음

<01-8 합집합>

Dim c As Range, uni As Range

For Each c In Range("a1:a10")
    If c = 4 Or c = 6 Then      ‘셀의 값이 4 또는 6이면 무시해라
    Else                       ‘4 또는 6이 아니면 아래 코드 실행
      If uni Is Nothing Then    ‘처음에는 uni변수에 아무것도 없으므로
        Set uni = c            ‘uni 변수에 c변수에 들어온 값을 넣고
      Else                     ‘두번째 부터는 uni변수에 값이 들어오므로
        Set uni = Union(uni, c)  ‘기존 uni변수에 보관된 셀과 새로운 c변수의 값을 합함
      End If
    End If
Next

If uni Is Nothing = 0 Then uni.Select  ‘uni변수에 보관된 셀이 있으면 선택해라

<01-9 교집합>

Private Sub Worksheet_Change(ByVal Target As Range) 
   If Target.Cells.Count > 1 Then Exit Sub
   If Not Intersect(Target, Columns("b")) Is Nothing Then  ‘B열에 값이 바뀌면
      Application.EnableEvents = False                   ‘실행문을 한번만 실행
       'To do      
      Application.EnableEvents = True                   ‘다시 이벤트 동작을 활성화
   End If
End Sub

<02-5 행 삭제 개선1>

Dim uni As Range
Dim i As Long, lR As Long

lR = Cells(Rows.Count, "a").End(xlUp).Row
For i = 2 To lR
   If Cells(i, "a") = "A-1" Then
      If uni Is Nothing Then
         Set uni = Cells(i, "a").Resize(, 2)
      Else
         Set uni = Union(uni, Cells(i, "a").Resize(, 2))
      End If
   End If
Next

If Not uni Is Nothing Then uni.Delete

<02-6 행 삭제 개선2>
Dim r, Dim a()
Dim i As Long, j As Long, k As Long

r = Range("a1", Cells(Rows.Count, "b").End(xlUp))               ‘raw data를 몽땅 r변수에 넣음
For i = 1 To UBound(r, 1)
   If Cells(i, "a") <> "A-1" Then                               ‘A-1이 아니면 배열에 넣음
      k = k + 1
      ReDim Preserve a(1 To 2, 1 To k)                        ‘기존 배열을 유지하면서
For r = 1 To 2
         a(r, k) = Cells(i, "a").Offset(0, r - 1).Value
      Next
   End If   
Next

Range("a1").CurrentRegion.ClearContents                       ‘기존 데이터를 모두 삭제
Range("a1").Resize(UBound(a, 2), 2) = Application.Transpose(a)    ‘배열 값을 뿌리기

<03-4 셀 병합 해제>
Dim rng As Range, c As Range
Set rng = Range("a1", Cells(Rows.Count, "a").End(3))
For Each c In rng
   If c.MergeCells Then
      With c.MergeArea
         .UnMerge
         .Value = c
      End With
   End If
Next

<04-5 문자 합치기>
Dim a()
Dim c As Range
Dim i As Long
   
For Each c In Columns("a").SpecialCells(2)
   ReDim Preserve a(i)
   a(i) = c
   i = i + 1
Next
   
Range("b1") = Join(a, ",")

<04-6 문자 나누기>
Dim s() As String
Dim i As Long
s = Split(Range("a1"), " ")
For i = 0 To UBound(s)
   Cells(i + 1, "b") = s(i)
Next
-----------------------------------------------
Dim s
Dim i As Long
s = Split(Range("a1"), " ")
For i = 0 To UBound(s)
   Cells(i + 1, "b") = s(i)
Next
----------------------------------------------
Dim s
Dim i As Long
   
For Each s In Split(Range("a1"), " ")
   Cells(i + 1, "b") = Trim(s)
   i = i + 1
Next

<05-1 컬렉션 개체로 특정 영역의 데이터 한방에 담기>
Dim nc As New Collection
Dim i As Long
Dim rng As Range, c As Range
   
Set rng = Range("a2", Cells(Rows.Count, "a").End(3))
   
For Each c In rng
   nc.Add c.Value
Next

<05-2 컬렉션 개체로 조건에 맞는 데이터만 한방에 담기>
Dim nc As New Collection
Dim rng As Range, c As Range

Set rng = Range("a2", Cells(Rows.Count, "a").End(3))

For Each c In rng
   If c = "A" Then
      nc.Add c.Offset(, 1).Value
   End If
Next

<05-3 컬렉션 개체로 중복되지 않은 고유한 항목만 담기>
Dim nc As New Collection
Dim rng As Range, c As Range

Set rng = Range("a2", Cells(Rows.Count, "a").End(3))
   
On Error Resume Next      ‘반드시 넣어 주어야 함
   For Each c In rng
      If Len(c) Then
         nc.Add c.Value, CStr(c)
      End If
   Next
On Error GoTo 0           ‘반드시 넣어 주어야 함

<06-1 특정 파일의 존재여부 확인>
   Dim FN As String
   FN = Dir(Environ("userprofile") & "\Desktop\Test\test.xlsx")
      
   If FN <> "" Then
      MsgBox FN
   Else
      MsgBox "파일이 존재하지 않습니다"
   End If

<06-2 특정 폴더의 존재 여부 확인>
   Dim PN As String
   Dim FN As String
   
   PN = Environ("userprofile") & "\Desktop\Test"
   FN = Dir(PN, vbDirectory)
 
   If FN <> "" Then
      MsgBox FN & " 존재"
   Else
      MsgBox "해당 폴더가 존재하지 않음"
   End If

<06-3 특정 폴더의 존재 여부 확인해서 없으면 만들기>
   Dim PN As String
   Dim FN As String
   
   PN = Environ("userprofile") & "\Desktop\Test"
   FN = Dir(PN, vbDirectory)
   
   If FN <> "" Then
      MsgBox FN & " 폴더가 존재합니다"
   Else
      MkDir PN
      MsgBox "폴더가 만들어졌습니다"
   End If

<06-4 특정 폴더 내, 모든 폴더 및 파일 이름 가져오기>
   Dim FN As String
   FN = Dir(Environ("userprofile") & "\Desktop\Test\", vbDirectory) 
   
   Do While FN <> ""
      Cells(Rows.Count, "a").End(3)(2) = FN
      FN = Dir()
   Loop

<06-5 특정 폴더 내, 모든 폴더의 이름 가져오기>
   Dim PN As String
   Dim FN As String
   
   PN = Environ("userprofile") & "\Desktop\Test\"
   FN = Dir(PN, vbDirectory)
   
   Do While FN <> ""
      
      If GetAttr(PN & FN) = vbDirectory Then 'getattr함수를 사용하여 dir함수가 반환한 이름이 파일? 폴더? 디렉토리? 인지 확인할 수 있다
         Cells(Rows.Count, "a").End(3)(2) = FN
      End If
      
      FN = Dir()
   Loop

<06-6 특정 폴더 내, 모든 파일의 이름 가져오기>
   Dim PN As String
   Dim FN As String
   
   PN = Environ("userprofile") & "\Desktop\Test\"
   FN = Dir(PN)

   Do While FN <> ""
      Cells(Rows.Count, "a").End(3)(2) = FN
      FN = Dir()   
   Loop

<06-7 특정 폴더 내, 첫번째 엑셀 파일의 이름 가져오기>
   Dim FN As String
   Dim PN As String
   
   PN = Environ("userprofile") & "\Desktop\Test\"
   FN = Dir(PN & "*.xls*")
   
   MsgBox FN

<06-8 특정 폴더 내, 모든 엑셀 파일의 이름 가져오기>
   Dim PN As String
   Dim FN As String
   
   PN = Environ("userprofile") & "\Desktop\Test\"
   FN = Dir(PN & "*.xls*")
   
   Do While FN <> ""
      Cells(Rows.Count, "a").End(3)(2) = FN
      FN = Dir()   
   Loop

<06-9 특정 폴더 내, 모든 엑셀 파일 통합하기>
   Dim PN As String
   Dim FN As String
   Dim wb As Workbook
   Dim ws As Worksheet
   
   Application.ScreenUpdating = False
   
   PN = Environ("userprofile") & "\Desktop\Test\"
   FN = Dir(PN & "*.xls*")
   
   If FN = "" Then
      MsgBox "폴더에 파일이 없습니다"
      Exit Sub
   End If
    'to do
   Do While FN <> ""
      Set wb = Workbooks.Open(Filename:=PN & FN, UpdateLinks:=0)
      Set ws = wb.Sheets(1)
      
      'to do
      
      wb.Close False
      
      FN = Dir()
   Loop
   
   
   Application.ScreenUpdating = True
   
   Set wb = Nothing
   Set ws = Nothing

<06-10 특정 파일만 자동으로 가져와서 작업하기>
   Dim FN As String
   Dim wb As Workbook
   Dim ws As Worksheet
   
   Application.ScreenUpdating = False
   
   FN = Environ("userprofile") & "\Desktop\Test\Test.xlsx"
      
   If IsFileExist(FN) = False Then
      MsgBox "파일이 존재하지 않습니다"
      Exit Sub
   End If
   
   If IsFileOpen(FN) = True Then
      MsgBox "파일이 이미 열려 있습니다. 닫고 다시 시작하세요"
      Exit Sub
   End If
   
   Set wb = Workbooks.Open(Filename:=FN, UpdateLinks:=0)
   Set ws = wb.Sheets(1)
   
   'to do
   
   wb.Close False
   
   Application.ScreenUpdating = True
   
   Set wb = Nothing
   Set ws = Nothing
'----------------------------------------------------------------------------
Function IsFileExist(FN As String) As Boolean
   IsFileExist = (Dir(FN) <> "")

End Function
'-----------------------------------------------------------------------------
Function IsFileOpen(FN As String) As Boolean
   Dim OpenFName As Workbook
   
   On Error Resume Next
   Set OpenFName = Workbooks(Dir(FN))
   IsFileOpen = (Err.Number = 0)
End Function

<06-11 특정 폴더를 유저가 선택해서 파일 통합하기>
   Dim PN As String
   Dim FN As String
   Dim wb As Workbook
   Dim ws As Worksheet
   
   ChDir ThisWorkbook.Path
   
   With Application.FileDialog(msoFileDialogFolderPicker)
      .Show
      If .SelectedItems.Count = 0 Then
         Exit Sub
      Else
         PN = .SelectedItems(1) & "\"
      End If
   End With
   
   FN = Dir(PN & "*.xls*")
   
   If FN = "" Then
      MsgBox "폴더에 파일이 없습니다"
      Exit Sub
   End If
   
   Do While FN <> ""
      Set wb = Workbooks.Open(Filename:=PN & FN, UpdateLinks:=0)
      Set ws = wb.Sheets(1)
      
      
      'To do
      wb.Close False
   
      FN = Dir()
   Loop

   Application.ScreenUpdating = True
   
   Set wb = Nothing
   Set ws = Nothing

<06-12 특정한 파일을 유저가 선택해서 작업하기>
   Dim FD As FileDialog
   Dim FN As Variant
   Dim wb As Workbook
   Dim ws As Worksheet
   
   Application.ScreenUpdating = False
   
   ChDir ThisWorkbook.Path
   
   Application.FileDialog(msoFileDialogFilePicker).Filters.Add "Excel Files", "*.xls*"
   
   Set FD = Application.FileDialog(msoFileDialogFilePicker)
   
   With FD
       .AllowMultiSelect = True   '여러개 파일 선택
       '.AllowMultiSelect = False   '한 개 파일 선택
       
       If .Show Then
   
           For Each FN In .SelectedItems
               Set wb = Workbooks.Open(Filename:=FN, UpdateLinks:=0)
               Set ws = wb.Sheets(1)
                  
              'To do
               
               wb.Close False
           Next
       End If
   
       
   End With

   Application.ScreenUpdating = True
   Set wb = Nothing
   Set ws = Nothing

<06-13 워크시트를 새 파일로 생성하기>
    Dim PN As String, FN As String
   
    Application.ScreenUpdating = False
   
    PN = ThisWorkbook.Path & "\"
    FN = ActiveSheet.Name & ".xlsx"
   
    If Dir(PN & FN) <> "" Then Kill PN & FN
   
    ActiveSheet.Copy
    ActiveSheet.Buttons.Delete
   
    ActiveWorkbook.SaveAs Filename:=PN & FN
    ActiveWorkbook.Close
   
    Application.ScreenUpdating = True

<06-14 모든 워크시트를 각각의 새 파일로 생성하기>
   Dim PN As String, FN As String
   Dim sh As Worksheet
   
   Application.ScreenUpdating = False
   
   PN = ThisWorkbook.Path & "\"
   
   For Each sh In ThisWorkbook.Worksheets
      FN = sh.Name & ".xlsx"
      
      If Dir(PN & FN) <> "" Then Kill PN & FN
      
      sh.Copy
      ActiveSheet.Buttons.Delete
      
      ActiveWorkbook.SaveAs Filename:=PN & FN
      ActiveWorkbook.Close
   Next
   
   Application.ScreenUpdating = True
   
   Set sh = Nothing

<08 시트 통합>
   Dim sh As Worksheet
   
   Application.ScreenUpdating = False
   
   Sheet1.Cells.Clear
   
   For Each sh In ThisWorkbook.Worksheets
      If sh.Name <> ActiveSheet.Name Then
         'To do
      
      End If
   
   Next
   
   Application.ScreenUpdating = True

<09-1 정렬 기본>
   Dim rng As Range
   
   Set rng = Range("a1").CurrentRegion
   ActiveSheet.Sort.SortFields.Clear
   
   rng.Sort Range("a1"), 1, Header:=xlYes
   'rng.Sort Range("a1"), 2, Header:=xlYes

<09-2 여러 필드 정렬(3개까지)>
   Dim rng As Range
   
   Set rng = Range("a1").CurrentRegion
   ActiveSheet.Sort.SortFields.Clear   
   
   With rng
      .Sort key1:=.Cells(1, 1), order1:=2, _
            key2:=.Cells(1, 2), order2:=1, _
            key3:=.Cells(1, 3), order3:=1, _
            Header:=xlYes
   
   End With

<09-3 여러 필드 정렬(3개 이상)>
   Dim i As Long
   Dim rng As Range
   
   Set rng = Range("a1").CurrentRegion
  
   With ActiveSheet.Sort
      .SortFields.Clear
      For i = 1 To rng.Columns.Count
         .SortFields.Add Key:=Cells(1, i), Order:=2
      Next
      
      .SetRange rng
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
      
   End With

<10-1 자동 필터>
Dim sh1 As Worksheet
Dim rng As Range

Set sh1 = Sheets("자동필터")
Set rng = sh1.Range("a1").CurrentRegion

If sh1.AutoFilterMode = 0 Then rng.AutoFilter
If sh1.FilterMode Then sh1.ShowAllData

rng.AutoFilter 2, Range("e2")
Range("a22").CurrentRegion.Clear

If rng.SpecialCells(xlCellTypeVisible).Count = 3 Then
   MsgBox "해당되는 데이터 없음"
     sh1.ShowAllData
   Exit Sub
End If
rng.SpecialCells(xlCellTypeVisible).Copy Range("a22")
sh1.ShowAllData

<10-2 고급 필터>
Dim rng As Range
Set rng = Range("a1").CurrentRegion
rng.AdvancedFilter xlFilterCopy, Range("e1:e2"), Range("a25")

<11-1 Find 기본>
Dim rng As Range, cf As Range

Range("e2").ClearContents

Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
Set cf = rng.Find(Range("d2").Value, , , xlWhole)

If Not cf Is Nothing Then
   Range("e2") = cf.Offset(, 1)
Else
   MsgBox "찾는 제품코드가 없습니다."
End If

<11-2 Find 응용>
Dim rng As Range, cf As Range
Dim adr As String
Dim i As Long

Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
Set cf = rng.Find("A-1", , , xlWhole)

If Not cf Is Nothing Then
   adr = cf.Address
   Do
      cf.Interior.ColorIndex = 43
      Set cf = rng.FindNext(cf)
   Loop Until cf.Address = adr
End If

<12-1 피벗 생성 기본>
Dim pt As PivotTable
Dim pc As PivotCache
Dim sd As Worksheet, ss As Worksheet
Dim rngS As Range, rngD As Range

Application.ScreenUpdating = False

Set ss = Sheets("raw")                       ‘raw data 시트
Set sd = Sheets("피벗")                      ‘피벗 생성될 시트

Set rngS = ss.Range("a1").CurrentRegion      ‘피벗의 원본 데이터 범위
Set rngD = sd.Range("a1")                   ‘피벗 생성될 시작 셀

sd.Cells.Clear

Set pc = ThisWorkbook.PivotCaches.Create(xlDatabase, rngS)   ‘피벗 캐쉬 영역이 먼저 생성
Set pt = pc.CreatePivotTable(rngD, "pv1")                     ‘캐쉬 영역을 기반으로 피벗 생성

With pt
   .AddFields "연령", "발신지_구"                            ‘연령별(행), 발신지구별(열)
   .AddDataField .PivotFields("통화건수"), , xlSum             ‘통화건수(∑값)의 합계
End With

Application.ScreenUpdating = True

Set sd = Nothing
Set ss = Nothing
Set rngS = Nothing
Set rngD = Nothing

<12-2 피벗 생성 기본 Plus>
Set pc = ThisWorkbook.PivotCaches.Create(xlDatabase, rngS)   ‘피벗 캐쉬 영역이 먼저 생성
Set pt = pc.CreatePivotTable(rngD, "pv1")                     ‘캐쉬 영역을 기반으로 피벗 생성

With pt
   .AddFields "연령", "발신지_구"                            ‘연령별(행), 발신지구별(열)
   .AddDataField .PivotFields("통화건수"), , xlSum             ‘통화건수(∑값)의 합계
   .RowAxisLayout xlTabularRow                            ‘보고서 레이아웃 : 테이블 형식
   .RowGrand = False                                      ‘행 총합계 표시 안함
   .ColumnGrand = False                                   ‘열 총합계 표시 안함
   
   For Each f In .PivotFields                                 ‘필드별 부분합 표시 안함
      f.Subtotals(1) = False
   Next
End With

<12-4 피벗 슬라이서 생성과 위치 지정>
Dim scc As SlicerCache
Dim scr As Slicer
Dim ss As Worksheet
Dim pt As PivotTable
Dim rng As Range

Set ss = Sheets("피벗")
Set pt = ss.PivotTables("pv1")


On Error Resume Next
   ThisWorkbook.SlicerCaches("성별_scc").Delete
On Error GoTo 0

Set scc = ThisWorkbook.SlicerCaches.Add2(pt, "성별", "성별_scc")
Set scr = scc.Slicers.Add(ss, , "성별슬라이서", "성별선택")

Set rng = ss.PivotTables("pv1").TableRange1

scr.Top = rng.Top
scr.Left = rng.Left + rng.Width + 20
scr.Height = rng.Height
scr.Width = 200

<13-1 차트 생성 기본>
Dim ws As Worksheet
Dim rs As Range, rd As Range
Dim sh As Shape
Dim ch As Chart
   
Set ws = Sheets("raw")        ‘raw 시트
Set rs = ws.Range("a1:b10")    ‘a1:b10영역이 차트 원본 영역
   
On Error Resume Next
   ws.ChartObjects.Delete      ‘raw 시트에 차트가 있으면 삭제
On Error GoTo 0

'차트생성 : 차트는 shape > chart 순으로 만들어짐
   Set sh = ws.Shapes.AddChart(XlChartType.xlColumnClustered)   ‘차트 종류의 이름
   Set ch = sh.Chart
   
   '차트 요소 생성
   With ch
      .SetSourceData rs                     ‘차트 원본범위
      .HasTitle = True                       ‘차트 제목 설정
      .ChartTitle.Text = "제품별 판매수량"     ‘차트 제목 입력
      .HasLegend = False                    ‘범례 해제
   End With
   
  '차트 이름, 위치, 크기
  With sh
      Set rd = ws.Range("f1:j10")             ‘차트가 들어갈 범위를 설정
      .Name = "cht1"                       ‘차트 이름
      .Top = rd.Top                         ‘차트 위치
      .Left = rd.Left                         ‘차트 위치
      .Width = rd.Width                     ‘차트 사이즈
      .Height = rd.Height                    ‘차트 사이즈
  
  End With

<13-2 분산형차트에 레이블 추가 및 마커 변경>
   Dim rng As Range, rd As Range
   Dim sh As Shape
   Dim ch As Chart
   
   Dim ser As Series
   Dim i As Integer, j As Integer
   Dim c As Range, lbl As Range
   
   Set rng = Sheet1.Range("b2", Sheet1.Cells(Rows.Count, "c").End(3))
   
   On Error Resume Next
      Sheet1.ChartObjects.Delete
   On Error GoTo 0
   
   '차트 생성
   Set sh = Sheet1.Shapes.AddChart2(, xlXYScatter)
   Set ch = sh.Chart
   
   '차트 요소 생성
   With ch
      .SetSourceData rng
      .HasTitle = True
      .ChartTitle.Text = "제품별 사이즈 측정"
      .HasLegend = False
   End With
   
   '차트 이름, 위치, 크기
   With sh
      Set rd = Sheet1.Range("e1:j11")
      .Name = "cht1"
      .Top = rd.Top
      .Left = rd.Left
      .Width = rd.Width
      .Height = rd.Height
   End With
   
   '레이블 추가
   Set ser = Sheet1.ChartObjects(1).Chart.SeriesCollection(1)
   Set lbl = Sheet1.Range("a2", Sheet1.Range("a2").End(xlDown))
   ser.HasDataLabels = True
   
   For Each c In lbl
      i = i + 1
      ser.Points(i).DataLabel.Text = c.Value
   Next
   
   '일정한 조건 갖추면 색상 변경
   Dim Yvals, Xvals
   Yvals = ser.Values
   Xvals = ser.XValues
   
      
   For i = LBound(Yvals) To UBound(Yvals)
      If Yvals(i) >= 170 And Xvals(i) >= 65 Then
         With ser.Points(i)
            .MarkerBackgroundColor = RGB(255, 0, 0)
            .MarkerStyle = -4168
         End With
      End If
   
   Next

<13-3 차트 삭제>
     Dim sh As Worksheet    '단일 시트의 모든 차트 삭제
     Set sh = Sheet1   
     If sh.ChartObjects.Count Then sh.ChartObjects.Delete


     Dim sh As Worksheet    '모든 시트의 모든 차트 삭제
     For Each sh In ThisWorkbook.Worksheets
        If sh.ChartObjects.Count Then
           sh.ChartObjects.Delete
        End If
     Next

<15-1 특정 경로의 텍스트 파일 가져오기>
   Dim c As Range
   Dim FilePath As String
   Dim data As String
   Dim i As Integer
   Dim arr
   
   Set c = Sheet1.Range("a1")
   c.CurrentRegion.Clear
   
   FilePath = Environ("userprofile") & "\Desktop\VBA_109\학자금상환현황.txt"
   Open FilePath For Input As #1
   
   Do Until EOF(1)
      Line Input #1, data
      
      arr = Split(data, ",")
      c.Offset(i).Resize(1, UBound(arr) + 1) = arr
      i = i + 1
   Loop
   
   Close #1

   c.CurrentRegion.Columns.AutoFit

<15-2 폴더 내, 모든 텍스트 파일 가져오기>
Dim c As Range, FilePath As String, FileName As String
   Dim data As String
   Dim i As Integer, FileNum As Integer
   Dim arr
   
   Sheet1.Cells.Clear
   Set c = Sheet1.Range("a1")     
   '폴더 선택 & 경로
   With Application.FileDialog(msoFileDialogFolderPicker)
      .Show
      If .SelectedItems.Count = 0 Then
         Exit Sub
      Else
         FilePath = .SelectedItems(1) & "\"
      End If
   End With   
   '폴더 내,텍스트 파일 존재 여부
   FileName = Dir(FilePath & "*.txt")
   If FileName = "" Then
      MsgBox "폴더 내, 텍스트 파일이 없습니다"
      Exit Sub
   End If   
   Do While FileName <> ""
         FileNum = FreeFile
         Open FilePath & FileName For Input As #FileNum
         
         Do Until EOF(FileNum)
            Line Input #FileNum, data
            arr = Split(data, ",")            
            If arr(0) <> "구분1" Then
               c.Offset(i).Resize(1, UBound(arr) + 1) = arr
               i = i + 1
            End If
         Loop
         
         Close #FileNum
         FileName = Dir
   Loop   
   c.CurrentRegion.Columns.AutoFit

<16 위, 아래 데이터가 같은지 다른지 비교해서 작업하기>
For Each c In rng      
      If c.Value = c.Offset(1).Value Then
         i = i + 1
      Else
         If i = 0 Then              ‘같지 않으면
            ‘To do
         Else                      ‘같으면
            ‘To do
         End If         
         i = 0
      End If
Next

<17 특정 색상이 칠해진 여러 셀 선택하기>
   Dim rng As Range, cf As Range, uni As Range
   Dim adr As String
   
   Application.FindFormat.Clear
   Application.FindFormat.Interior.ColorIndex = 6
   
   Set rng = Columns("a").SpecialCells(2)
   Set cf = rng.Find("*", searchformat:=True)
   
   If cf Is Nothing = 0 Then
      adr = cf.Address
      Do
         If uni Is Nothing Then
            Set uni = cf
         Else
            Set uni = Union(uni, cf)
         End If
         
         Set cf = rng.Find("*", after:=cf, searchformat:=True)
      Loop While cf.Address <> adr
   End If

   If uni Is Nothing = 0 Then uni.Select

   Application.FindFormat.Clear

<18 프로시저 처리 속도 확인>
   Dim sT As Date, eT As Date   
   sT = Timer
       ‘실행 코드

   eT = Timer   
   MsgBox Format(eT - sT, "0000.00000") & "초"

<19-1 숫자를 반환할 때>
Dim MyRow As Long
Application.DisplayAlerts = False
   
 On Error Resume Next
 MyRow = Application.InputBox("작업할 행을 입력하세요", Type:=1)
 If err Then Exit Sub      
     ‘To do
 Application.DisplayAlerts = True

<19-2 셀주소를 반환할 때>
   Dim MyRng As Range

   Application.DisplayAlerts = False
   
   On Error Resume Next
TA:
      Set MyRng = Application.InputBox("셀범위를 드래그하세요", Type:=8)
         
      If err Then Exit Sub
      
      If MyRng.Count = 1 Then
         MsgBox "2개 이상의 셀을 선택해야 합니다"
         GoTo TA
      End If
      
         ‘To do
   On Error GoTo 0   
   Application.DisplayAlerts = True

<20 시트 보호되어 있는 시트에서 매크로 작업 가능하도록 하기>
Sub 메인프로시저()
   Dim sh As Worksheet
   Set sh = Sheet1   
   Call fnUnProtect(sh)
      'To do   
   Call fnProtect(sh)
End Sub

Sub fnProtect(sh As Worksheet)
   sh.Protect Password:="1234567", AllowFormattingColumns:=True, _
   AllowFormattingRows:=True, AllowFiltering:=True
End Sub

Sub fnUnProtect(sh As Worksheet)
   sh.Unprotect "1234567"   
End Sub