https://www.youtube.com/playlist?list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj
VBA
엑셀의 기능적인 한계를 만나는 시점이 온다. 많은 양의 데이터를 처리, 분석하는데 시간도 오래 걸리고 반복적으로 특정한 기능을 사용하고 있다면 솔루션은 바로 VBA!!!
www.youtube.com
제가 vba 공부하면서 최고로 도움이 되었던 강의 입니다.
엑셀 VBA #01 / VBA 썰(說) [VBA]
엑셀 VBA #02 / 셀 하나 선택하기_1 [VBA]
1. 특정열의 열번호 알아내기
직접실행창 Ctrl+G
? range("a1").column
Dim cn As Long
cn = 7
Range("A" & cn).Select
Cells(cn, "A").Select개체 Cells는 Set으로 변수 선언
Dim c As Range
Set c = Cells(1, "A")엑셀 VBA #03 / 셀 하나 선택하기_2 [VBA]
B열의 마지막셀 선택
Cells(Rows.Count, "B").End(xlUp).Select엑셀 VBA #04 / 셀 하나 선택하기_3 [VBA]
전체행 전체열
Columns(2).Select
Columns("B").Select
Rows(4).Select
Range("A1").EntireColumn.Select
Range("C4").EntireColumn.Select
Range("B6").EntireRow.Select1. 특정범위 행의 수
Dim rng As Range
Dim rn As Long
Set rng = Range("A1:D10")
rng.EntireRow.Select
rn = rng.Rows.Count
MsgBox rn엑셀 VBA #05 / 셀 하나 선택하기_4 [VBA]
offset속성
기준셀.offset(행,열)
Range("A1").offset(1,1).Select ' 1행1열 만큼
Range("C7").offset(-1,-1).Select데이터를 누적할 때 - 마지막 행 다음 행
Cells(Rows.Count, "C").End(xlUp).offset(1).Select
같은 내용
Cells(Rows.Count, "F").End(3)(2).SelectC열의 값 중에서 116 이상 값 추출해서 F열에 누적
Dim c As Range
For Each c In Range("C1:C10")
If c >=116 Then
Cells(Rows.Count, "F").End(3)(2) = c
End If
Next엑셀 VBA #06 / 셀 범위 선택하기_1 [VBA]
Range("A1", Cells(Rows.Count, "D").End(xlUp)).Select
Range("A1", Cells(Rows.Count, "C").End(xlUp).offset(,1)).SelectDim last_c As Long
last_c = Range("A1").End(xlDown).Rows
Range("A1:D" & last_c).SelectRange("A1").CurrentRegion.Select ' 반드시 기준은 Cell이어야 된다.worksheets(1).UsedRange.Select ' 반드시 기준은 worksheets여야 된다.엑셀 VBA #07 / 셀 범위 선택하기_2 [VBA]
기준개체.resize(행,열)
Dim rng As Range
Set rng = Range("A1").CurrentRegion
rng.Resize(2,3).Select ' rng 전체 범위 중 일부 2행3열만 선택
rng.Resize(,3).Select ' rng 전체 범위 중 일부 A열, B열, C열 선택제목행만 빼고 Resize
Dim rng As Range
Dim cn As Long
Set rng = Range("A1").CurrentRegion
cn = cells(1,columns.Count).End(xlToLeft).Column ' 1행 마지막 열번호
rng.offset(1).Resize(rng.Rows.Count-1,cn).Select ' -1 제목행엑셀 VBA #08 / 셀 범위 선택하기_3 [VBA]
불연속적인 데이터 범위 선택시 Union
Union(Columns("B"), Columns("D")).Select
A열에서 4와 6을 제외한 데이터만 선택
Dim c As Range
Dim r as Range
For Each c In Range("A1:A10") ' Range("A1",Cells(Rows.Count,"A"))
If c = 4 or c = 6 Then
Else
If r Is Nothing Then
Set r = c
Else
Set r = Union(r,c)
End If
End If
Next
If r is Nothing = 0 Then r.Select엑셀 VBA #09 / 셀 범위 선택하기_4 [VBA]
기준개체.specialcells(옵션)
Dim rng As Range
Set rng = Range("A1").CurrentRegion
' 범위에서 빈 셀만 선택
' rng.SpecialCells(xlCellTypeBlanks).Select
rng.SpecialCells(xlCellTypeBlanks) = "*"
' 범위에서 오류 셀만 선택
' rng.SpecialCells(xlCellTypeFormulas, xlErrors).Select
rng.SpecialCells(xlCellTypeFormulas, xlErrors) = ""
' 범위에서 수식있는 셀만 선택
' rng.SpecialCells(xlCellTypeFormulas).Select
' 만약 수식이 없으면 에러 난다
On Error Resume Next
rng.SpecialCells(xlCellTypeFormulas).Select
If Err Then MsgBox "이 워크시트에는 수식이 없습니다."
On Error GoTo 0엑셀 VBA #10 / 셀 범위 선택하기_5 [VBA]
' 자동매크로(매크로 기록기)
엑셀 VBA #11 / 셀 범위 선택하기_6 [VBA]
' 비연속적으로 떨어진 다중범위 Areas
' 다중범위 Areas
' 기준개체.Areas
' 선택한 다중범위 주소
MsgBox Selection.Address(0,0)' 다중범위에서 첫번째 범위의 주소
MsgBox Selection.Areas(1).Address(0,0)' 다중범위 순차적으로 보기
Dim a As Range
Dim adr() ' 동적배열
Dim i As Long
For Each a In Selection.Areas ' 선택된 다중범위
redim preserve adr(i) ' preserve 메모리의 값을 유지해라
adr(a) = a.Address(0,0)
i = i + 1
Next
MsgBox "선택된 다중범위는 " & vbcr & join(adr, vbcr) ' vbcr 줄바꾸기조사식
엑셀 VBA #12 / 셀 범위 선택하기_7 [VBA]
' 데이터 중간에 빈 행 삭제하기
Dim rng As Range
Dim a As Range
Set rng = range("A1", Cells(Rows.Count, "A").End(xlUp)
For Each a in rng.SpecialCells(xlCellTypeBlanks).Areas
If a.Count > 1 Then
' a.Resize(a.Count - 1, 1).EntireRow.Delete ' 기준개체.delete - 한개의 행은 남겨라
a.Resize(a.Count - 1, 4).EntireRow.Delete ' 4 열갯수
End if
Next엑셀 VBA #13 / 셀 범위 선택하기_8 [VBA]
' 교집합 Intersect
' Intersect(범위,범위,...)
Intersect(Range("A1:A10"),Range("C4:E12")).Select' 합집합 Union
' 만약 교집합이 없으면
If Not Intersect(Range("A1:D10"),Range("C12:E20")) Is Nothing Then
'교집합이 있으면 이 곳에 실행할 코드를 입력
End If엑셀 VBA #14 / 셀 범위 선택하기_9 [VBA]
Sheet에 코드 입력
' 선택한 셀에 변화가 있으면 실행
1. 이벤트 창에서 Intersect
Worksheet-Change
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo er
If Not Intersect(Target,Columns("A:D")) Is Nothing Then
If Target.Row > 1 And Target.Row < 12 Then '데이터영역
If vba.IsNumeric(Target) Then '숫자이면
Else
MsgBox "숫자로 입력하세요."
Target = ""
Target.Select
End If
End If
End If
er:
End Sub엑셀 VBA #15 / 셀 범위 선택하기_10 [VBA]
' 셀 범위안에 빈 셀 채우기
' 영역 설정 - Ctrl+G - 옵션 - 빈셀 - '=A2' - Ctrl+Enter
' 영역 설정 - F5 - 옵션 - 빈셀 - '=A2' - Ctrl+Enter
Dim rng As Range
Set rng = Range("A2",Cells(Rows.Count,"A").End(xlUp).offset(1) ' offset(1)은 마지막데이터 밑에 빈칸1개 있을때
rng.SpecialCells(xlCellTypeBlanks).Formula = "=A2"엑셀 VBA #16 / 셀 범위 선택하기_11 [VBA]
' 병합된 셀 해제하고 채우기
Dim rng As Range
Dim c As Range
Dim r As Range
Set rng = Range("A2", Cells(Rows.Count,"A").End(xlUp))
For Each c In rng
If c.MergeCells Then
If c.MergeArea.Cells(1).Address = c.Address Then ' Cells(1) 병합된 셀의 첫번째셀
Set r = c.MergeArea ' 병합된 영역 r
c.MergeArea.UnMerge
r.FillDown
End If
End If
Next엑셀 VBA #17 / If 조건문 [VBA]
If IsNumeric(Range("A2")) Then MsgBox "숫자입니다"
If IsNumeric(Range("A2")) Then
MsgBox "숫자입니다"
End If
If IsNumeric(Range("A2")) Then
MsgBox "숫자입니다"
Else
MsgBox "숫자가 아닙니다"
End If
If Range("A2") >= 8 Then
Range("B2") = "합격"
ElseIf Range("A2") >= 6 Then
Range("B2") = "재시험"
Else
Range("B2") = "탈락"
End If엑셀 VBA #18 / Like 연산자 [VBA]
If Range("A2") = "A1" And Len(Range("A2")) = 2 Then MsgBox "OK"' If 문자셀 Like 패턴 Then ...
' If 문자셀 Like [A-Z] Then ... 대문자이면
' If 문자셀 Like [a-z] Then ... 소문자이면
' If 문자셀 Like [가-힣] Then ... 한글이면
' If 문자셀 Like [!가-힣] Then ... 한글이 아니면
' If 문자셀 Like [0-9] Then ... 숫자이면
' If 문자셀 Like "A*" Then ... A로 시작하는 문자이면
' If 문자셀 Like "A?" Then ... A로 시작하는 귀에 한문자가 따라오면
' If 문자셀 Like "A#" Then ... A로 시작하는 귀에 숫자가 따라오면
' If Not 문자셀 Like "A*" Then ... A로 시작하는 문자가 아니면
If Range("A2") Like "A#" Then MsgBox "OK" ' A로 시작하고 뒤에 숫자 한자리가 오면
If Range("A3") Like "###-[A-D][A-D][A-D]###" Then MsgBox "OK" ' 숫자 세자리와 -대문자A에서 D까지 3개의 문자엑셀 VBA #19 / Like 연산자_예제1 [VBA]
' VBA.Len함수
Debug.Print Len(Range("A2") ' 직접 실행창에 출력' VBA.Mid함수
Debug.Print Mid(Range("A2"), 1, 1) ' 첫번째에서 하나만' 한글만 뽑아내라
Dim i As Long
Dim LT As String
For i = 1 To Len(Range("A2"))
If Mid(Range("A2"),i,1) Like "[가-힣]" Then
LT = LT & Mid(Range("A2"),i,1)
End If
Next
If Len(LT) Then Range("B2") = LT엑셀 VBA #20 / Like 연산자_예제2 [VBA]
' 대문자D로 시작해서 뒤에 숫자로 오는 것만 추출
Dim i As Long
Dim cnt As Long
cnt = Range("A1").CurrentRegion.Rows.Count
For i = 2 to cnt
For j = 1 To Len(Cells(i,"A"))
If Mid(Cells(i,"A"),j,5) Like "D####" Then
Cells(i,"B") = Mid(Cells(i,"A"),j,5)
End If
Next
Next개발도구-삽입-양식컨트롤-command버튼-매크로지정
엑셀 VBA #21 / For~Next_1 [VBA]
' For 변수 = 시작값 To 끝값 Step 증가값(감소값)
Dim i As Long
Dim cnt As Long
' A1 공백행
' A2 제목이라면
' cnt = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Rows.Count ' 순수 데이터 갯수
' For i = 1 To cnt
' cnt = Range("A1").CurrntRegion.Rows.Count ' 마지막 행번호
cnt = Range("A1").End(xlDown).Row ' 마지막 행번호
For i = 2 To cnt
If Cells(i,"A") >= 90 Then
Cells(i,"B") = "A"
ElseIf Cells(i,"B") >= 80 Then
Cells(i,"B") = "B"
ElseIf Cells(i,"B") >= 70 Then
Cells(i,"B") = "C"
Else
Cells(i,"B") = "F"
End If
Next엑셀 VBA #22 / For~Next_2 [VBA]
구구단
Dim i As Long
Dim j As Long
For i = 2 To 9 '열
For j = 1 To 9 '행
Sheets("완성").Cells(j + 1, i - 1) = i & " × " & j & " = " & i * j 'Cells(2행,1열)
Next
Next
Range("A1").CurrentRegion.EntireColumn.AutoFit ' 자동열넓이엑셀 VBA ♡별이와 함께 ♡ VBA 색상표 만들기 [VBA]
Range("A1").Interior.Color = RGB(43,230,255)
Range("A1").Interior.Color = vbYellow
Range("A1").Interior.ColorIndex = 45 ' 1 ~ 56테마색 jcpicker.exe 검색, 매크로기록기
기본색상표
Dim i As Long
Dim j As Long
Dim k As Long
k = 1
For i = 1 To 8 '행
For j = 1 To 7 '열
Sheets("완성").Cells(i, j).Interior.ColorIndex = k 'Cells(1행,1열)
Sheets("완성").Cells(i, j) = k
t = t + 1
Next
Next1 2 3 4 5 6 7
8 9
...
50...56
엑셀 VBA #24 / For~Next_4 [VBA]
시트핸들링
시트 추가
Sheets.Add after:=ActiveSheet, Count:=3 ' 활성화된 시트 다음에 추가
Sheets.Add after:=Sheets(Sheets.Count), Count:=3 ' 마지막 시트에 새로운 시트 추가월별시트추가
'시트 2개 있는 상태에서
Dim i as Long
Application.ScreenUpdating = False
Sheets("Main").Activate
For i = 1 To 12
Sheets.Add(after:=Sheets(Sheets.Count)).Name = i & "월"
Next시트 숨기기
'첫번째시트 "Main" 두번째시트 "숨기기" 2개의 시트가 있는 상태에서
'12개의 월별시트가 추가되어 총14개의 시트가 있다
MsgBox ActiveSheet.Index
Sheets("Main").Activate
For i = 1 To 12
Sheets(ActiveSheet.Index + 1 + i).Visible = False
Next시트 삭제
Application.DisplayAlerts = False' 경고창 안보이게
Sheets("Main").Activate
For i = 1 To 12
Sheets(ActiveSheet.Index + 1 + 1).Delete ' 인덱스번호주의 3번째 시트삭제
'인덱스Main시트, 1 두번째시트, 1 1월~12월까지 하나씩 3번 시트가 됨
Next
Application.DisplayAlerts = True' 경고창 안보이게마지막 시트 Sheets(Sheets.Count)
엑셀 VBA #25 / For Each~Next_1 [VBA]
시트 숨기기 - 하나씩 하나씩 숨김
Application.ScreenUpdating = False
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "Main" Then
ElseIf sh.Name = "외우기" Then
Else
sh.Visible = False
End If
Next
Application.ScreenUpdating = True변수에 시트이름을 넣고 나중에 한꺼번에 숨기기
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim s() '동적배열
Dim i As Long
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "Main" Then
ElseIf sh.Name = "외우기" Then
Else
ReDim Preserve s(i) ' Preserve 기존의 값을 보관을 하면서
s(i) = sh.Name
i = i + 1
End If
Next
Sheets(s).Visible = False ' 변수s에 저장된 시트 한꺼번에 숨김
Application.ScreenUpdating = True보기-조사식창
엑셀 VBA #26 / For Each~Next_2 [VBA]
고유목록(중복된 항목제거) - New Collection 개체
Dim dc As New Collection
Dim c As Range
Dim i As Long
Dim rc As Range
Dim rs As Range
' Cells(11, "A").CurrentRegion.ClearContents
On Error Resume Next
For Each c In Range("A2",Cells(Rows.Count,"A").End(xlUp))
dc.Add Trim(c),CStr(Trim(c))
Next
On Error GoTo 0
'붙여넣기
Range("A11") = "고유목록별 합계"
Set rc = Range("A2",Cells(Rows.Count,"A").End(xlUp))
Set rs = Range("A2",Cells(Rows.Count,"A").End(xlUp)).offset(,1)
For i = 1 To dc.Count
Cells(i+11,"A") = dc(i)
Cells(i+11,"B") = Application.sumif(rc,dc(i),rs)
' 조건범위,조건,합을구할범위
Next엑셀 VBA #27 / 배열 [VBA]
정적배열
Dim a(2) ' 3개의 빈방 0 1 2 생성
Dim i As Long
For i = 0 To 2
a(i) = i
Next
Erase a ' 정적배열에서 Erase는 방은 그대로 유지하는데 값은 지워짐보기-조사식창
동적배열
Dim aa() ' 아직 방이 안정해짐 size가 안정해졌으니까
Dim i As Long
ReDim aa(2) ' 빈방이 3개 만들어짐
For i = 0 To 2
aa(i) = i
Next
Erase aa ' 동적배열에서 Erase는 값도 지워지고 방도 지워진다ReDim 을 For 문안에 넣으면
Dim aa() ' 아직 방이 안정해짐 size가 안정해졌으니까
Dim i As Long
Dim cnt As Long
cnt = 2
For i = 0 To 2
'ReDim aa(i) ' 빈방이 1개씩 만들어짐 '주의 두번째 돌때 첫번째 방aa(0)의 값이 Empty 비어버리게 된다
ReDim Preserve aa(i) ' 기존 방 값 그대로 유지
aa(i) = i
Next
Erase aa ' 동적배열에서 Erase는 값도 지워지고 방도 지워진다보기-조사식창
엑셀 VBA #28 / 워크시트 함수 [VBA]
Application.WorksheetFunction.Sum(합을구할범위)
match함수 - 첫번째 위치만 찾아줌
B로 시작하는 문자가 있는 위치
MsgBox Application.WorksheetFunction.Match("B*",Range("A2",Cells(Rows.Count,"A").End(xlUp)))
'만약 조건에 맞는 값이 없으면 에러
If IsError(Application.WorksheetFunction.Match("B*",Range("A2",Cells(Rows.Count,"A").End(xlUp))))
Exit Sub
End IF
' 이렇게 해도 에러
' 수정 - WorksheetFuntion 삭제하면 에러 안남
If IsError(Application.Match("B*",Range("A2",Cells(Rows.Count,"A").End(xlUp))))
Exit Sub
End IF' 준비
Sheets("워크시트").Activate
Cells(Rows.Count, "B").End(xlUp).ClearContents
' 개체변수는 Set문으로 시작
Set rs = Range("B2", Cells(Rows.Count, "B").End(xlUp))
If IsError(Application.Match(Application.Min(rs), rs, 0)) = False Then
r = Application.Match(Application.Min(rs), rs, 0)
Cells(Rows.Count, "B").End(xlUp).Offset(1) = Cells(r + 1, "A")
End If엑셀 VBA #29 / VBA함수(split) [VBA]
'VBA.Split(range("A2")," ")
Dim s
Dim i As Long
s = Split(Range("A2"), " ")
For i = 0 To UBound(s) ' 마지막 방의 위치
Cells(Rows.Count, "A").End(xlUp).Offset(1) = s(i)
Next'VBA.Split(range("A2")," ")
Dim s
Dim i As Long
Dim a
s = Split(Range("A2"), " ")
For Each a In s
Cells(Rows.Count, "A").End(xlUp).Offset(1) = a
Next엑셀 VBA #30 / 정렬_1 [VBA]
엑셀 VBA #42 / Find메서드_기본 [VBA]
사전작업
동적데이터유효성검사-목록-'=OFFSET($G$2,0,0,COUNTA($G:$G)-1,1)
Sheets("Find메서드기본").Activate
If Not IsEmpty(Range("G2")) Then
Range("G2", Cells(Rows.Count, "G").End(xlUp)).ClearContents
End If
' 다른열에 임시로 고유값 '
Dim dc As New Collection
Dim c As Range
Dim i As Long
On Error Resume Next
For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
dc.Add Trim(c), CStr(Trim(c))
Next
On Error GoTo 0
For i = 1 To dc.Count
Cells(i + 1, "G") = dc(i)
' 조건범위,조건,합을구할범위 '
Next
' 정렬 '
Dim rng As Range
Set rng = Range("G2", Cells(Rows.Count, "G").End(xlUp))
Sheets("Find메서드기본").Sort.SortFields.Clear ' 사용자지정목록이 있으면 적용하지마라 '
'rng.Sort rng(1, 1) '
rng.Sort rng(1, 1), xlAscending, Header:=xlNo, Orientation:=xlSortColumns
'rng.Sort rng(1, 1), xlDescending, rng(1, 2), , xlAscending Header:=xlNo, Orientation:=xlSortColumns '
' 첫번째 기준위치(rng(1행,1열) '
' xlAscending오름차순,xlDescending내림차순 '
' 두번째 기준위치(rng(1행,2열) '
' 타입 - 생략 '
'xlAscending오름차순,xlDescending내림차순 '
'header:=xlNo 머릿글 없음(xlYesNoGuess) '
'orientation:=xlSortColumns정렬방향(xlSortColumns,xlSortRows) 'Find
Dim rng As Range
Dim cf As Range
Range("E2").ClearContents
Set rng = Range("A2", Cells(Rows.Count, "A").End(xlUp))
If Range("D2").Value = Range("A2").Value Then ' ★★★★
Range("E2") = Range("A2").Offset(, 1) ' 첫행이 일치하면 Find할 필요없음
Else
Set cf = rng.Find(Range("D2").Value, , , xlWhole)
' after 생략하면 다음행부터 찾는다는 의미★★★★★
' lookin 생략하면 수식에서 찾는위치
' lookat 전체셀내용일치 xlwhole 부분적으로라도일치 xlpart
If Not cf Is Nothing Then
Range("E2") = cf.Offset(, 1)
Else
MsgBox "해당되는 제품코드가 없습니다."
End If
End If엑셀 VBA #43 / Find메서드_변형1 [VBA]
Dim rng As Range
Dim cf As Range
Dim ad As String
Set rng = Range("A2", Cells(Rows.Count, "A").End(xlUp))
rng.Interior.Color = xlNone
Set cf = rng.Find(Range("D2").Value, , , xlWhole)
' after 생략하면 다음행부터 찾는다는 의미 xlnext 아래로 xlprevious 위로 '
' lookin 생략하면 수식에서 찾는위치 '
' lookat 전체셀내용일치 xlwhole 부분적으로라도일치 xlpart '
If Not cf Is Nothing Then ' 있으면 '
ad = cf.Address '처음 주소 '
Do
cf.Interior.ColorIndex = 43
Set cf = rng.FindNext(cf) '기존에 찾았던 셀 이후로 다시 찾아라 '
Loop Until cf.Address = ad 'cf의 주소가 처음 주소와 같을 때까지 진행하겠다
End If엑셀 VBA #44 / Find메서드_변형2 [VBA]
역순으로 리스트하기
Worksheets("Find메서드변형2").Activate
'위로 찾기 '
Dim rng As Range
Dim cf As Range
Dim ad As String
If Not Range("E3") Is Nothing Then
Range("E3", Cells(Rows.Count, "E").End(xlUp)).ClearContents
End If
Set rng = Range("B3", Cells(Rows.Count, "B").End(xlUp))
Set cf = rng.Find(Range("E2"), Range("B22"), , xlWhole, , xlPrevious) ' 위 방향으로'
If Not cf Is Nothing Then
ad = cf.Address
Do
Cells(Rows.Count, "E").End(xlUp).Offset(1) = cf.Offset(, -1)
' Cells(Rows.Count, "E").End(3)(2) = cf.Offset(, -1) '
Set cf = rng.FindPrevious(cf)
Loop Until cf.Address = ad
End If엑셀 VBA #45 / Find메서드_변형3 [VBA]
' 다른 시트에 중복값이 있는지'
Dim sh8 As Worksheet
Dim sh7 As Worksheet
Dim rng As Range
Dim c As Range
Dim cf As Range
Dim ad As String
Set sh8 = Sheets("bts2018")
Set sh7 = Sheets("bts2017")
Set rng = sh7.Range("B3", sh7.Cells(Rows.Count, "B").End(xlUp))
For Each c In sh8.Range("B3", sh8.Cells(Rows.Count, "B").End(xlUp))
Set cf = rng.Find(c, , , xlWhole)
If Not cf Is Nothing Then
ad = cf.Address
Do
c.Offset(, 2) = "○"
Set cf = rng.FindNext(cf)
Loop Until cf.Address = ad
End If
Next엑셀 VBA #46 / Replace 메서드 [VBA]
'유령문자'
' Application.WorksheesFunction.Replace'
' 범위.Replace '
Sheets("Replace메서드").Activate
Dim rng As Range
Set rng = Range("A1").CurrentRegion
rng.Replace ChrW(160), "" 'ascii code'Replace메서드_여러가지유령문자
'유령문자'
' Application.WorksheesFunction.Replace'
' 범위.Replace '
Sheets("Replace메서드").Activate
Dim rng As Range
Dim LT As Variant 'array변수는 variant타입으로 받아야 됨'
Dim e As Variant
Set rng = Range("A1").CurrentRegion
'chrw(160)유령문자,chrw(13)캐리지리턴,chrw(10)라인피드'
LT = Array(ChrW(160), ChrW(13), ChrW(10))
For Each e In LT
rng.Replace e, ""
Next엑셀 VBA #47 / 중복데이터 처리_1 [VBA]
중복값찾기
Sheets("중복데이터removeduplicate").Activate
If Not IsEmpty(Range("G2")) Then
Range("G2", Cells(Rows.Count, "G").End(xlUp)).Clear
End If
Dim rng As Range
Set rng = Range("A2", Cells(Rows.Count, "A").End(xlUp))
rng.Copy Range("G2")
Range("G2", Cells(Rows.Count, "G").End(xlUp)).RemoveDuplicates 1, xlNo '1열,xlNo머리글'고급필터
Sheets("중복데이터removeduplicate").Activate
If Not IsEmpty(Range("G2")) Then
' Range("G2", Cells(Rows.Count, "G").End(xlUp)).Interior.Color = xlNone'
' Range("G2", Cells(Rows.Count, "G").End(xlUp)).ClearContents'
Range("G2", Cells(Rows.Count, "G").End(xlUp)).Clear
End If
Dim rng As Range
Set rng = Range("A2", Cells(Rows.Count, "A").End(xlUp))
rng.AdvancedFilter xlFilterInPlace, , , 1
'xlFilterInPlace 현재위치에 필터'
'xlFilterCopy 다른장소에 복사'
'동일한 레코드는 하나만'
rng.SpecialCells(xlCellTypeVisible).Copy Range("G2")
'SpecialCells화면에보이는것만'
'필터 설정된 거 해제해서 모든 데이터 다 보이게'
ActiveSheet.ShowAllDatanew collection
Sheets("중복데이터removeduplicate").Activate
If Not IsEmpty(Range("G2")) Then
' Range("G2", Cells(Rows.Count, "G").End(xlUp)).Interior.Color = xlNone
' Range("G2", Cells(Rows.Count, "G").End(xlUp)).ClearContents
Range("G2", Cells(Rows.Count, "G").End(xlUp)).Clear
End If
Dim rng As Range
Dim dc As New Collection
Dim c As Range
Dim i As Long
On Error Resume Next
Set rng = Range("A2", Cells(Rows.Count, "A").End(xlUp))
For Each c In rng
If Len(c) Then
dc.Add Trim(c), CStr(Trim(c))
End If
Next
On Error GoTo 0
For i = 1 To dc.Count
Cells(Rows.Count, "G").End(xlUp).Offset(1) = dc(i)
Next엑셀 VBA #48 / 중복데이터 처리_2 [VBA]
신규항목추출
Sheets("중복데이터신규항목추출").Activate
If Not IsEmpty(Range("A13")) Then
Range("A13", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2).Clear
End If
Dim rO As Range
Dim rC As Range
Dim c As Range
Set rO = Range("A2", Range("A2").End(xlDown))
Set rC = Range("D2", Cells(Rows.Count, "D").End(xlUp))
For Each c In rC
If Application.CountIf(rO, c) = 0 Then '조건범위,조건'
' c.Resize(, 2).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1) '
c.Resize(, 2).Copy Cells(Rows.Count, "A").End(3)(2)
End If
Next엑셀 VBA #49 / New Collection_버블정렬의 콜라보 [VBA]
Sheets("newcollectionbubblesort").Activate
If Not IsEmpty(Range("C1")) Then
Range("C1", Cells(Rows.Count, "C").End(xlUp)).ClearContents
End If
If Not IsEmpty(Range("E1")) Then
Range("E1", Cells(1, Columns.Count).End(xlToLeft)).ClearContents
End If
Dim dc As New Collection
Dim rng As Range
Dim a()
Dim c As Range
Dim i As Long
Dim j As Long
Dim e As Variant
Dim temp As Variant
Set rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
' 고유목록 추출'
On Error Resume Next
For Each c In rng
If Len(c) Then
dc.Add Trim(c), CStr(Trim(c))
End If
Next
On Error GoTo 0
'배열에 넣기'
ReDim a(dc.Count - 1) ' 배열은 0부터 '
For i = 0 To dc.Count - 1
a(i) = dc(i + 1) ' item은 1부터 '
Next
' 사전 정렬하기 버블정렬 '
For i = 0 To dc.Count - 2
For j = i + 1 To dc.Count - 1 '아래쪽 셀과 비교'
If a(i) > a(j) Then
temp = a(i)
a(i) = a(j)
a(j) = temp
End If
Next
Next
' 배열을 가로방향으로 '
Range("E1").Resize(1, UBound(a) + 1) = a
' 배열을 세로방향으로 1차원배열을 세로방향으로 바꿀려면'
Range("C1").Resize(UBound(a) + 1, 1) = Application.Transpose(a)
' 배열을 콤보상자에 넣기 '
ActiveSheet.DropDowns(1).RemoveAllItems
For Each e In a
ActiveSheet.DropDowns(1).AddItem e
Next
ActiveSheet.DropDowns(1).Selected(1) = True엑셀 VBA #50 / 중복데이터 처리_3 [VBA]
'중복데이터삭제하기'
Sheets("중복데이터처리3").Activate
If Not IsEmpty("E3") Then
Range("E3", Cells(Rows.Count, "E").End(xlUp)).ClearContents
End If
Dim rng As Range
Dim lastRow As Long
Dim lastColumn As Long
Dim i As Long
Dim j As Long
Dim rngX As Range
Set rng = Range("a3", Cells(Rows.Count, "D").End(xlUp))
' 마지막 행의 번호'
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
' lastRow = rng.Rows.Count '
' 총 열의 갯수 '
lastColumn = rng.Columns.Count
' lastColumn = Cells(3, Columns.Count).End(xlToLeft).Column '
rng(1, lastColumn + 1).Resize(rng.Rows.Count, 1) = "=concatenate(a3,b3,c3,d3)"
' 비교 '
For i = 3 To lastRow - 1
For j = i + 1 To lastRow
If Cells(i, "E") = Cells(j, "E") Then
If rngX Is Nothing Then
Set rngX = Cells(j, "A").Resize(1, lastColumn + 1)
Else
Set rngX = Union(rngX, Cells(j, "A").Resize(1, lastColumn + 1))
End If
End If
Next
Next
'If rngX Is Nothing = 0 Then rngX.Delete '
If Not rngX Is Nothing Then rngX.Delete
' rng(1, lastColumn + 1).Resize(rng.Rows.Count, 1).ClearContents '
Range("D3", Cells(Rows.Count, "D").End(xlUp)).ClearContents엑셀 VBA #51 / 중복데이터 처리_4 [VBA]
사용자정의함수
Function fnMerge(rng As Range, i As Long) As String
Dim col As Long
Dim k As Long
Dim str As String
col = rng.Columns.Count
For k = 1 To col
str = str & rng(i, k) 'i 행, k 열'
Next k
fnMerge = str
End FunctionSheets("중복데이터삭제단계2").Activate
Dim rng As Range
Dim cntRow As Long
Dim cntColumn As Long
Dim strI As String
Dim strJ As String
Dim rngX As Range
Dim i As Long
Dim j As Long
Set rng = Range("A3", Cells(Rows.Count, "D").End(xlUp))
cntRow = rng.Rows.Count
cntColumn = rng.Columns.Count
For i = 1 To cntRow - 1
'사용자정의함수'
strI = fnMerge(rng, i) 'i 행'
For j = i + 1 To cntRow
strJ = fnMerge(rng, j) 'j 행'
If strI = strJ Then
If rngX Is Nothing Then
Set rngX = rng(j, "A").Resize(1, cntColumn)
Else
Set rngX = Union(rngX, rng(j, "A").Resize(1, cntColumn))
End If
End If
Next
Next
If Not rngX Is Nothing Then rngX.Delete엑셀 VBA #52 / 중복데이터 처리_5 [VBA]
고유항목별 합계구하기
Sheets("중복데이터처리5").Activate
Dim rgu As Range, c As Range
Dim e
Dim tot As Long
Application.ScreenUpdating = False
Set rgu = Range("f2", Cells(Rows.Count, "f").End(xlUp))
'고유 시군구 추출
On Error Resume Next
For Each c In rgu
If Len(c) Then
gu.Add Trim(c), CStr(Trim(c))
End If
Next
On Error GoTo 0
'시군구별 합계>시트생성해서 뿌리기
For Each e In gu
tot = Application.SumIf(rgu, e, rgu.Offset(, 2))
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = e
With Sheets(e)
.Range("a1").Resize(1, 2) = Array("시군구", "통화건수")
.Range("a2") = e
.Range("b2") = tot
End With
Next
Application.ScreenUpdating = True엑셀 VBA #126 / Vlookup시리즈2_배열 활용 [VBA]
1차원배열 - 0 부터 시작
arr(0) arr(1) arr(2)
2차원배열 - ★ 1 부터 시작 (★ 셀범위로 만든 배열)
arr(1,1)__________arr(1,2)__________arr(1,3)
arr(2,1)__________arr(2,2)__________arr(2,3)
arr(3,1)__________arr(3,2)__________arr(3,3)
아래방향으로 아래방향으로 아래방향으로
Sheets("vba126가공").Activate
Dim rngS, rngF ' ★ 셀범위를 배열로 집어넣을때는 Variant 타입으로 선언해야 된다
Dim i As Long, j As Long
Dim arr()
Application.ScreenUpdating = False
' Sheets("vba126가공").Range("e2:e" & Sheet2.Range("a1").End(xlDown).Row).Clear
Sheets("vba126가공").Range("e2", Cells(Rows.Count, "E").End(xlUp)).ClearContents
rngS = Sheets("vba126기준").Range("a2", Sheets("vba126기준").Cells(Rows.Count, "b").End(3)) '2개열'
rngF = Sheets("vba126가공").Range("a2", Sheets("vba126가공").Cells(Rows.Count, "a").End(3)) '1개열'
ReDim arr(1 To UBound(rngF, 1), 1 To 1) '행열'
For i = 1 To UBound(rngF, 1) '찾을'
For j = 1 To UBound(rngS, 1) '원본'
If rngF(i, 1) = rngS(j, 1) Then
arr(i, 1) = rngS(j, 2)
Exit For '영상에서 이 코드는 빼먹었습니다. 넣어야 합니다. 1:1로 매칭되므로 값을 찾았으면 안쪽 for문을 빠져나와야지 그렇지 않으면 끝까지 루프를 돌므로 시간이 더 소요가 됩니다.
End If
Next
Next
Sheets("vba126가공").Range("e2").Resize(UBound(arr, 1), 1) = arr
Application.ScreenUpdating = True
Erase arr
Erase rngS
Erase rngF엑셀 VBA #118 / Dictionary 개체_기본 [VBA]
Sheets("Dictionary개체기본").Activate
'Dictionary
'Dim dict As Object
'Set dict = CreateObject("scripting.dictionary") ' 반드시 같이 설정해야 된다
'도구-참조-Microsoft Scripting Runtime
Dim dict As New Scripting.Dictionary
Dim i As Long
Dim arr() As Variant
dict.Add "사과", 111 ' key값은 중복된 값은 안되고, 고유한 항목이어야 된다.
dict.Add "바나나", 222
dict.Add "딸기", 333
' Debug.Print dict("바나나") ' Ctrl+G 직접실행창
dict.Items ' 조사식 추가
' dict.Items(0)_____111
' dict.Items(1)_____222
' dict.Items(2)_____333
dict.Keys
' dict.Keys(0)_____"사과"
' dict.Keys(1)_____"바나나"
' dict.Keys(2)_____"딸기"
' 값 뿌리기
For i = 0 To UBound(dict.Items) ' 배열 시작값 0 dict 'UBound 최대인덱스값
' Cells(i + 1, "O") = dict.Items(i) 'Range("O1") = dict.Items(0)
ReDim Preserve arr(i)
arr(i) = dict.Items(i) 'Range("O1") = dict.Items(0)
Next
Debug.Print UBound(arr)
Debug.Print LBound(arr)
Range("O1").Resize(UBound(arr) + 1, 1) = Application.Transpose(arr) '행열엑셀 VBA #119 / Dictionary 개체_실무 [VBA]
Sheets("Dictionary개체기본").Activate
Columns("D:I").ClearContents
Range("A1").CurrentRegion.Copy Range("D1")
' 중복된 항목제거
Range("D1").CurrentRegion.RemoveDuplicates Array(1, 2), xlYes '제목
' 배열에 집어넣기 - 고유값
'Dictionary
'Dim dict As Object
'Set dict = CreateObject("scripting.dictionary") ' 반드시 같이 설정해야 된다
'도구-참조-Microsoft Scripting Runtime
Dim dict As New Scripting.Dictionary
Dim rngS As Range
Dim c As Range
Dim s As Variant
Dim i As Long
Dim rngT As Range
Application.ScreenUpdating = False
Set rngS = Range("D2", Cells(Rows.Count, "D").End(xlUp))
For Each c In rngS
If dict.Exists(c.Value) Then ' 만약 중복되면 ~해라
dict(c.Value) = dict(c.Value) & "," & c.Offset(, 1) 'A1,A2 이렇게 계속 연결해라
Else
dict.Add c.Value, c.Offset(, 1) 'dict.Add 키값,---키값은 중복되면 안됨
End If
Next
Set rngT = Range("G1")
' 문자나누기 split
For i = 0 To UBound(dict.Items) ' 배열 시작값 0 dict 'UBound 최대인덱스값
s = Split(dict.Items(i), ",") ' 비밀노트 p19 하단 varient타입이나 string타입
rngT.Offset(, i) = dict.Keys(i) 'A
rngT.Offset(1, i).Resize(UBound(s) + 1, 1).Value = Application.Transpose(s) ' 최대 index에서 1을 더하면 인덱스값
Next
'Columns("C:E").Delete
Application.ScreenUpdating = True
'개체변수 nothing
Set dict = Nothing
Set c = Nothing
Set rngS = Nothing
Set rngT = Nothing엑셀 VBA #127 / Vlookup시리즈3_배열+Dictionary활용 [VBA]
배열
Dim rngS, rngF
Dim i As Long, j As Long
Dim arr()
Dim sT As Date, lT As Date
sT = Timer
Application.ScreenUpdating = False
Sheet2.Range("e2:e" & Sheet2.Range("a1").End(xlDown).Row).Clear
rngS = Sheet1.Range("a2", Sheet1.Cells(Rows.Count, "b").End(3))
rngF = Sheet2.Range("a2", Sheet2.Cells(Rows.Count, "a").End(3))
ReDim arr(1 To UBound(rngF, 1), 1 To 1)
For i = 1 To UBound(rngF, 1)
For j = 1 To UBound(rngS, 1)
If rngF(i, 1) = rngS(j, 1) Then
arr(i, 1) = rngS(j, 2)
Exit For '영상에서 이 코드를 빼먹었습니다. 넣어야 합니다. 1:1로 매칭되므로 값을 찾았으면 안쪽 for문을 빠져나와야지 그렇지 않으면 끝까지 루프를 돌므로 시간이 더 소요가 됩니다.
End If
Next
Next
Sheet2.Range("e2").Resize(UBound(arr, 1), 1) = arr
Application.ScreenUpdating = True
lT = Timer
MsgBox Format(lT - sT, "0000.000000") & "초"
Erase arr
Erase rngS
Erase rngF
배열+Dictionary
Dim dict As New Scripting.Dictionary
Dim rngS, rngF ' worksheet의 특정영역을 배열로 받을 때는 variant 로 받는다
Dim i As Long
Dim arr()
Dim sT As Date, lT As Date
sT = Timer
Application.ScreenUpdating = False
Sheet2.Range("e2:e" & Sheet2.Range("a1").End(4).Row).ClearContents
rngS = Sheet1.Range("a2", Sheet1.Cells(Rows.Count, "b").End(3)) ' variant는 set문 안쓴다
For i = 1 To UBound(rngS, 1) ' 1 첫번째 인수의 제일 큰값
If dict.Exists(rngS(i, 1)) Then ' key값이 존재하면 = 중복된 값이 존재
Else
dict.Add rngS(i, 1), rngS(i, 2) '중복된 값이 없는 고유값일때 key + value
End If
Next
' dict.Keys 조사식창 추가
' dict.Items 조사식창 추가
rngF = Sheet2.Range("a2", Sheet2.Cells(Rows.Count, "a").End(3))
ReDim arr(1 To UBound(rngF, 1), 1 To 1)
For i = 1 To UBound(rngF, 1)
If dict.Exists(rngF(i, 1)) Then ' key 중복값이 존재하면
arr(i, 1) = dict(rngF(i, 1)) ' item == dict(key)
Else '고유값 생성
End If
Next
Sheet2.Range("e2").Resize(UBound(arr, 1), 1) = arr
Application.ScreenUpdating = True
lT = Timer
MsgBox Format(lT - sT, "0000.000000") & "초"
Erase rngS
Erase rngF
Erase arr
Set dict = Nothing
'컴퓨터 > 엑셀' 카테고리의 다른 글
| [엑셀VBA] 엑셀 로그인 시스템 만들기(비밀번호 포함) (0) | 2023.09.07 |
|---|---|
| vba 내선번호 배열 드래그앤드롭 (0) | 2023.09.05 |
| vba 배열 resize (0) | 2023.08.28 |
| vba listbox를 다른 listbox에 넣기 (0) | 2023.08.27 |
| 엑셀 팁 (0) | 2023.08.26 |