'업무 능력 향상/엑셀 VBA 활용'에 해당되는 글 113건

색상 개수와 색깔 표시하기

동일한 값이 3번 이상 들어간 경우 색상을 넣어서 표시하고 싶다면?

아래와 같은 결과를 얻고 싶다.

해당 VBA 샘플파일 첨부합니다.

동일색상처리.xlsm

VBA 코드는 아래와 같습니다.

Option Explicit
Sub Cell_Cnt()

    Dim rngC, rng As Range    '// 각 셀을 넣을 변수
    Dim rngAll As Range  '// 색상 전체 데이터 영역을 넣을 변수
    Dim rngTarget As Range  '// 전체 데이터 영역을 넣을 변수
    Dim cnt, i As Long
    Dim Max_Cnt As Double   '// 상황에 따라 Long, Double 지정
   
    Application.ScreenUpdating = False        '화면 업데이트 (일시) 정지
    Columns("G:H").EntireColumn.ClearContents   '// 값을 산출할 열 전체를 초기화
    '-------------------- B열~D열을 G열에 복사 ----------------------------------
    Set rngTarget = Range([A2], Cells(Rows.Count, "D").End(3))
    i = 2
    For Each rngC In rngTarget
        Cells(i, "G").End(3)(2).Value = rngC.Value
        i = i + 1
    Next rngC
   '------------------- G열의 중복값 모두 제거 ----------------------
    Cells(1, "G").Value = "구분"
    For i = 2 To Cells(Rows.Count, "G").End(3).Row          '// G열 각셀을 순환
        For j = i + 1 To Cells(Rows.Count, "G").End(3).Row
            If Cells(i, "G") = Cells(j, "G") Then
               Cells(j, "G").Delete Shift:=xlUp         '// 셀을 위로 밀면서 삭제
               j = j - 1                                '// 셀이 삭제되었으므로 변수 1을 빼줌
            End If
        Next j
    Next i
    '----------------- 오름차순 정렬 --------------------------------
    With Range([G2], Cells(Rows.Count, "G").End(3)) '//G2 셀부터 마지막 셀까지
        .Sort key1:=Range("G2"), order1:=xlAscending      '//오름차순 정렬
        .HorizontalAlignment = xlCenter     '// 글자를 가운데 정렬
    End With

    '------------------- 중복 횟수 구하기 --------------------------------
    Max_Cnt = 0
    Set rngAll = Range("G2", Cells(Rows.Count, "G").End(3))  '// G열 데이터영역을 변수에
    Cells(1, "H").Value = "횟수"
    For Each rng In rngAll
        For Each rngC In rngTarget
            If rng.Value = rngC.Value Then
                Max_Cnt = Max_Cnt + 1
                rng.Offset(0, 1).Value = Max_Cnt
            End If
        Next rngC
        Max_Cnt = 0
    Next rng
   
    With Range([G2], Cells(Rows.Count, "H").End(3)) '//G2 셀부터 마지막 셀까지
        .Sort key1:=Range("H2"), order1:=xlDescending      '//내림차순 정렬
        .HorizontalAlignment = xlCenter     '// 글자를 가운데 정렬
    End With
   
    '------------------ 색상 칠하기 -----------------------------------------------
    For Each rngC In Range("G2", Cells(Rows.Count, "G").End(3))
       Call ColSet(rngTarget, rngC, rngC.Offset(0, 1))
    Next rngC
       
    '------------------ 개체변수 초기화(메모리 비우기) -----------------------------
    Set rngAll = Nothing
    Set rngTarget = Nothing
   
    MsgBox "작업완료"
   
End Sub

Function ColSet(rngAll, cell, Val) As Long
    Dim rngC As Range
    Dim i As Long
    For Each rngC In rngAll
        If rngC.Value = cell.Value Then
            Select Case Val.Value
                Case 3: rngC.Font.Color = vbRed
                Case 4: rngC.Font.Color = vbBlue
                Case Else: rngC.Font.Color = vbBlack
            End Select
        End If
    Next rngC
End Function

이름별로 구매금액 합계 구하기

이름별로 구매금액의 합계를 구하는 VBA Code 입니다.

Option Explicit
Sub SameNmae_Sum()

    Dim rngC As Range    '// 각 셀을 넣을 변수
    Dim rngAll As Range  '// 색상 전체 데이터 영역을 넣을 변수
    Dim rngTarget As Range  '// 전체 데이터 영역을 넣을 변수
    Dim cnt, i As Long
    Dim Sum_Cnt As Double   '// 상황에 따라 Long, Double 지정
   
    Application.ScreenUpdating = False        '화면 업데이트 (일시) 정지
   
    '-------------------- B열을 G열에 복사 ----------------------------------
    Set rngTarget = Range([B2], Cells(Rows.Count, "B").End(3))
    For Each rngC In rngTarget
        rngC.Offset(0, 5).Value = rngC.Value    '// B열을 기준으로 0부터 시작해서 5번째
    Next rngC
  
    '------------------- G열의 중복값 모두 제거 및 오름차순 정렬 ----------------------
    Set rngAll = Range("G2", Cells(Rows.Count, "G").End(3))  '// G열 데이터영역을 변수에
    Cells(1, "G").Value = "성명"
    Cells(1, "G").HorizontalAlignment = xlCenter '// 가운데 정렬
    For Each rngC In rngAll                             '// G열 각셀을 순환
        cnt = Application.CountIf(rngAll, rngC)   '각셀의 countif 값을 변수에
        If cnt > 1 Then
            rngC.Resize(, 1).Clear   '//그 열의 데이터를 삭제
        End If
     Next rngC

    With Range([G2], Cells(Rows.Count, "G").End(3)) '//G2 셀부터 마지막 셀까지
        .Sort key1:=Range("G2"), order1:=xlAscending      '//오름차순 정렬
        .HorizontalAlignment = xlCenter     '// 글자를 가운데 정렬
    End With

    '---------------------- 같은 이름별로 구매금액 더하기 -----------------------------------
    Sum_Cnt = 0
    Columns("H:H").EntireColumn.ClearContents   '// 값을 산출할 열 전체를 초기화
    Cells(1, "H").Value = "구매금액"
    For Each rngC In rngAll
        For i = 2 To Cells(Rows.Count, "B").End(3).Row
            If rngC.Value = Cells(i, "B").Value Then
                   Sum_Cnt = Sum_Cnt + Cells(i, "C").Value   '//구매금액은 C열 이므로
                   rngC.Offset(0, 1).Value = Sum_Cnt
                   rngC.Offset(0, 1).HorizontalAlignment = xlCenter '// 가운데 정렬
                   rngC.Offset(0, 1).NumberFormat = "#,###"  '// 셀서식 : 3단위 콤마
            End If
        Next i
        Sum_Cnt = 0
    Next rngC
       
    '------------------ 개체변수 초기화(메모리 비우기) -----------------------------------
    Set rngAll = Nothing
    Set rngTarget = Nothing
   
    MsgBox "작업완료"

End Sub

Sum_of_Same_Name.xlsm

SameName_Sum.vbs

상단메뉴에서 [삽입] [모듈] 선택하면 나오는 창에다가 위의 VBS파일 내용을 복사하여 붙여넣기 하면 됩니다.

또는 샘플로 나온 파일을 위와 같이 열어서 보셔도 되구요.

중요한 건 내가 작업하고자 하는 셀에 변수열만 잘 바꿔서 작업하면 된다는 겁니다.

현재 시트 Text File로 내보내기

현재(활성화된) 엑셀 시트를 구분자(deLimiter)로 구분하여 텍스트 파일로 내보내는 VBA code 입니다.

Sub ActiveSheet_TextExport()
' Export Each Sheet As Text File
   Dim rng As Range
   Dim iRow As Long, iCol As Integer
   Dim sTxt As String, sPath As String
   Dim ff As Integer

   ff = FreeFile
   ' 파일을 다루려면 파일 핸들을 얻어야 한다.
   ' 파일핸들은 파일번호라고도 하는데, 운영체제에서 프로그램이 파일을 구분할 수 있도록 만든
   ' 고유의 식별번호로 중복되지 않는 정수형 숫자이다.

    sPath = ThisWorkbook.Path & "\"
    ' 파일의 경로
    ' Workbook 개체 : 엑셀 문서 도는 엑셀 파일을 지칭한다.
    ' Worksheet 개체 : 엑셀 시트를 말한다.
    ' Range 개체 : 엑셀의 셀 또는 셀 집합(범위)를 말한다.

    ' FilePath = Application.GetSaveAsFilename(filefilter:="Text Files (*.txt),*.txt", Title:="저장")
    ' GetSaveAsFilename 메서드를 사용하여 사용자가 원하는 경로에 이름을 지정하여 저장할 수 있음.
    ' 내보내기 파일명을 하나만 지정하는 경우에는 이렇게 지정하면 됨

    Open sPath & ActiveSheet.Name & ".txt" For Output As #ff
     ' 파일번호를 얻은 다음에는 파일을 열어야 한다. 파일을 열려면 open문을 사용한다.
     ' Open pathname For mode As [#]filenumber
     ' pathname은 파일의 전체 경로 및 이름을 지정하는 문자열이다.
     ' mode는 Input(읽기용도), Output(쓰기용도), Append(추기기록용), Binary(이진파일용)
     ' filenumber는 1에서 511 사이에 있는 유효한 파일 번호로 FreeFile 함수로 사용 가능한 파일 번호를 얻는다.

     ' Save 대화상자를 설정하여 열 경우에는 ....
     ' If Directory = False Then Exit Sub '(← Save 대화상자에서 취소를 누를 경우
     ' Open FilePath For Output As #ff '← 파일을 연다. 파일의 번호는 #ff

    Set rng = ActiveSheet.UsedRange

    deLimiter = ";"     '// 구분자 수정해서 사용하세요

    For iRow = 1 To rng.Rows.Count  '// 1행부터 마지막 행까지
        For iCol = 1 To rng.Columns.Count  '// 1열부터 오른쪽 최대 열까지
            sTxt = sTxt & ActiveSheet.Cells(iRow, iCol).Value & deLimiter
        Next iCol
        Print #ff, Left(sTxt, Len(sTxt) - 1)
         ' 파일에 데이터를 쓰기 위해서는 Print # 문을 사용한다.
         ' Print #filenumber, output
         ' Line Input # 문으로 읽어 온 데이터는 일반적으로 Print #을 사용하여 파일을 저장
         ' Write #filenumber, outputlist
         ' Print#과 달리 출력하는 데이터의 형식에 맞추어 파일에 기록한다.

       sTxt = vbNullString
    Next iRow
    Close #ff   '// 작업을 마치고 파일을 닫는다

End Sub

필요하신 분은 파일 받아서 활용하세요.

TextExport.vbs

csv_to_textfle.vbs

색상별로 시간합계 구하기

문의사항이 같은 색으로 더해진 시간들만 더하고 싶을 때

같은 색상별로 시간의 합계를 구하고 싶다면 어떻게 해야 할까요?

먼저 서로 다른 색상을 구해야 합니다. 사실 이 부분 테스트한다고 잘못 생각해서 시간허비 많이 했네요

처음부터 Msgbox 를 사용해서 확인해 가면서 했으면 금방 찾아서 시간낭비는 안했을텐데 ㅠㅠㅠ

Option Explicit
Sub SameColor_Sum()
    Dim rngC, rngT As Range    '// 각 셀을 넣을 변수
    Dim rngData As Range      '// 전체 데이터 영역을 넣을 변수
    Dim rngVariable As Range  '// 색상 데이터 영역 변수
    Dim i As Long
    Dim Max_Cnt As Double   '// 변수 유형을 Integer 로 지정하면 오류 발생
   
    Application.ScreenUpdating = False        '화면 업데이트 (일시) 정지   
    '-------------------- D열에 색상 및 색상값 복사 ----------------------------------
    Set rngData = Range([B2], Cells(Rows.Count, "B").End(3))
    For Each rngC In rngData
        rngC.Offset(0, 2).Value = rngC.Interior.ColorIndex
        rngC.Offset(0, 2).Interior.ColorIndex = rngC.Interior.ColorIndex
    Next rngC
  
    '------------------- D열의 중복값 모두 제거 및 오름차순 정렬 ----------------------
    Set rngVariable = Range("D2", Cells(Rows.Count, "D").End(3))  'D열 데이터영역을 변수에
    For Each rngT In rngVariable                               'D열 각셀을 순환
        If Application.CountIf(rngVariable, rngT) > 1 Then  '각셀의 countif 값을 변수에
            rngT.Resize(, 1).Clear   '그 셀의 데이터를 삭제
        End If
    Next rngT
    Range([D2], Cells(Rows.Count, "D").End(3)).Sort [D2], 1   '//오름차순 정렬
   
    '---------------------- 같은 색상의 값을 더하기 -----------------------------------
    Range([E2], Cells(Rows.Count, "E").End(3)).ClearContents '// 값 초기화
    For Each rngT In rngVariable
        For i = 2 To Cells(Rows.Count, "B").End(3).Row
            If rngT.Value = Cells(i, "B").Interior.ColorIndex Then
                   Max_Cnt = Max_Cnt + Cells(i, "B").Value
                   rngT.Offset(0, 1).Value = Max_Cnt
            End If
        Next i
        Max_Cnt = 0
    Next rngT
   
    '---------------- D열 색상만 남기고 값은 지우기 -------------------------------------
    For Each rngT In rngVariable              'D열 각셀을 순환
        rngT.ClearContents
    Next rngT
       
    With ActiveSheet   '// 결과를 표시할 Sheet 선택
        .Cells(1, "D").Value = "색상"
        .Cells(1, "E").Value = "시간합계"
        '--------------- 가운데 정렬, 선그리기 ----------------------------
        .Range(.[D1], .Cells(Rows.Count, "E").End(3)).HorizontalAlignment = xlCenter
        .Range(.[E2], .Cells(Rows.Count, "E").End(3)).NumberFormat = "h:mm:ss" '// 시간표시
        .Range(.[D1], .Cells(Rows.Count, "E").End(3)).Borders.LineStyle = 1     '// 사용영역 선그리기
        .Range(.[D1], .Cells(Rows.Count, "E").End(3)).Sort .[E2], 2    '// 값을 내림차순으로 정렬
    End With
       
    '------------------ 개체변수 초기화(메모리 비우기) -----------------------------------
    Set rngVariable = Nothing
    Set rngData = Nothing
   
    MsgBox "작업완료"   
End Sub

SameColor_Sum.vbs

Sum_of_Same_Color_Area.xlsm

첨부된 예제 받아서 확인해보세요.

한줄 한줄 실행하는 건 F8키 누르면 됩니다.

Vlookup를 이용한 현재 재고 파악

현재 재고를 파악하는 건데요. 기존 재고에서 일간 판매량이 있을 경우 일간 판매량을 빼주면 현재 재고가 됩니다.

Sub Vlookup_Sales()
'Application.VLOOKUP(lookup_value, table_array, column_index, range_lookup)

    Dim lookup_value As Range
    Dim table_array As Range
    Dim rngC As Range
    Dim varTemp As Variant
   
    Set lookup_value = Range("A3:A12")
    Set table_array = Range("A18:C22")
    'Set table_array = Workbooks("VLookup_Sample_v1.xlsx").Sheets("work").Range("A2:B31")
      '// 다른 파일에 있는 값과 비교하고자 할 때
     
    For Each rngC In lookup_value
        varTemp = Application.VLookup(rngC, table_array, 3, 0)
        '// 서로 일치하는게 있으면 table_array 의 세번째 열을 가져와라
        If IsError(varTemp) Then   '// 에러 #N/A 일 경우
            rngC.Offset(0, 3).Value = rngC.Offset(0, 2).Value
        Else
            rngC.Offset(0, 3).Value = rngC.Offset(0, 2).Value - varTemp
        End If
    Next rngC
   
    Set lookup_value = Nothing '// 변수 초기화
    Set table_array = Nothing
   
End Sub

예제 파일 첨부 합니다. VBA 코드는 예제 파일에 포함되어 있습니다.

Vlookup_Sales.xlsm

다른파일과 중복검사하는 Vlookup VBA

엑셀의 다른 파일에 있는 데이터와 중복되는 데이터가 있는지 검사하고 싶을 때 사용하는 VBA 입니다.

현재 입력한 데이터가 중복되는지 여부를 알고 싶을 때가 있더라구요.

VBA 소스코드 입니다.

어떻게 수정해서 사용해야 하는지 감이 잡히시죠?

첨부된 파일에서 동작하는 VBA 와 위 예시로 작성한 소스코드 VBA 를 약간 다르게 했는데 아주 쉬운거라서 금방 이해가 되실 겁니다.

중복검사 아이콘만 누르면 순식간에 중복된 값을 찾아서 표시를 해줍니다.

중복되지 않은 것은 빈공간으로 표시가 되구요.

VLookup VBA-02.vbs

VLookup VBA-02.xlsm

VLookup_Sample_v1.xlsx

셀 분리하여 다른 시트에 뿌리기

셀 분리하여 다른 시트에 뿌리는 VBA 입니다.

바로 앞의 게시물과 동일한데 결과만 다른 시트에 뿌리는 것입니다.

Sub Cell_MultiSplit()
    Dim rngC    As Range   '// 한 Cell 씩 변하는 변수 지정
    Dim rngTarget As Range '// 대상 범위 지정변수
    Dim varTemp() As String  '// 전체영역을 넣기위한 variant형 string 변수
    Dim deLimiter As String  '// 문자 구분자 변수
   
    Application.ScreenUpdating = False  '화면 업데이트 (일시)정지

    Set rngTarget = Columns(1).SpecialCells(2)
    '// SpecialCells(2) : 상수가 들어있는 셀
  
    deLimiter = "/"             '//문자 구분자
        For Each rngC In rngTarget
            varTemp = Split(rngC, deLimiter)       '//선택한 셀을 쪼개서 배열에 넣음
            'rngC.Offset(, 2).Resize(1, UBound(varTemp) + 1) = varTemp   '//현재 Sheet 에 뿌림
            '// Resize(RowSize,ColumnSize) : 지정된 범위의 크기를 조정
            '// Rowsize : 새 범위의 행 수를 지정
            '// ColumnSize : 새 범위의 열 수를 지정
            '// Ubound(arrayname, dimension) : 배열에서 지정된 차원의 최대 범위를 Long으로 반환
            '// arrayname : 배열 변수의 이름
            '// dimension 은 생략하면 1차원을 의미
            With Sheet2
                .Cells(rngC.Row, "C").Resize(1, UBound(varTemp) + 1) = varTemp
                .Columns("C:G").AutoFit
            End With
        Next rngC
    Set rngTarget = Nothing '// 변수 초기화
    MsgBox "작업완료"
   
End Sub

Cell_Split_VBA_othersht.vbs

Cell_Split_VBA_othersht.xlsm

Cells(행, 열) 이 For Each 구문에서 rngC 의 값이 변하면서 변동되므로

Cells(행, "C") 로 행은 변하는 값이므로 rngC.Row 로 현재 행의 값을 구함

열은 뿌리고 싶은 열을 직접 지정함

[VBA] 셀 분리하여 현재 시트에 뿌리기

엑셀에서 문자를 분리하고 싶은 경우가 있습니다.

이럴 경우 분리하는 방법으로 Split 함수를 이용하는 방법도 있고, Instr 함수를 이용하는 방법도 있습니다.

Instr 함수는 분리 구분자의 위치를 반환하여 MID함수랑 같이 사용하여 분리할 수 있습니다.

단순하게 구분자(delimiter)로 분리만 한다면 Split 함수가 편합니다.

분리한 것을 현재 셀에다가 할 것인가 아니면 옆에 있는 셀에다가 표시할 것인가를 먼저 정합니다.

옆셀에다가 뿌리는 것은 Offset 함수를 사용합니다.

Offset(,2) 는 Offset(0,2) 로 같은 행, 열 2 이동하라는 의미입니다.

Sub Cell_MultiSplit()
    Dim rngC    As Range   '// 한 Cell 씩 변하는 변수 지정
    Dim rngTarget As Range '// 대상 범위 지정변수
    Dim varTemp() As String  '// 전체영역을 넣기위한 variant형 string 변수
    Dim deLimiter As String  '// 문자 구분자 변수
   
    Application.ScreenUpdating = False  '// 화면 업데이트 (일시)정지

    Set rngTarget = Columns(1).SpecialCells(2)
    '// SpecialCells(2) : 상수가 들어있는 셀
  
    deLimiter = "/"       '//문자 구분자
    For Each rngC In rngTarget
        varTemp = Split(rngC, deLimiter)  '//선택한 셀을 쪼개서 배열에 넣음
        rngC.Offset(, 2).Resize(1, UBound(varTemp) + 1) = varTemp
        '// Resize(RowSize,ColumnSize) : 지정된 범위의 크기를 조정
        '// Rowsize : 새 범위의 행 수를 지정
        '// ColumnSize : 새 범위의 열 수를 지정
        '// Ubound(arrayname, dimension) : 배열에서 지정된 차원의 최대 범위를 Long으로 반환
        '// arrayname : 배열 변수의 이름
        '// dimension 은 생략하면 1차원을 의미
    Next rngC
    
    Set rngTarget = Nothing '// 변수 초기화
    Columns("C:G").AutoFit
End Sub

Cell_Split_VBA.vbs

Cell_Split_VBA.xlsm

위 VBA 코드를 복사하여 Alt + F11 키 누른다음 삽입 --> 모듈 눌러서 나오는 화면에 붙여넣기 하세요.

그리고 매크로 버튼만들기(http://link2me.tistory.com/151) 하고 연결시키면 됩니다.

SpecialCells(2) 의 의미가 뭔지 알고 싶다면 엑셀에서 도움말 F1를 눌러보세요.

Resize 를 해주는 이유는 구분자(delimiter)로 분리되는 배열(varTemp)의 범위가 동적으로 변할 수 있어서 입니다.

Resize(1,n) 이라는 건 행은 1이고 열의 크기는 n 으로 변한다는 것

rngC, rngTarget 개념 설명은 다른 게시물 http://link2me.tistory.com/215 참조하면 되요.

실행결과는

Resize 를 배열변수 고려없이 그냥 상수(숫자)로 직접 지정하면 어떤 변화가 일어나는지 확인해보면 압니다.

[VBA] 연속되는 값의 증가 최대값 모두 구하기

바로 이전 게시물을 버전업하여 작성한 것입니다.

VBA 고수분의 자료를 참조하여 응용하고 재 작성한 것입니다.

자료의 양이 방대할 경우에는 모든 값을 다 구해야 하는 거 아닌가 싶기도 해서 다시 구현해 봤습니다.

가령 구하는 값의 종류가 10개 라고 할 때에도 자동으로 10개의 값에 해당하는 증가 최대값을 모두 자동으로 구하는 식입니다.

Option Explicit

Sub MAX_Duplicate_Cnt()
    Dim rngCh, rngT           '// 입력할 열 글자
    Dim i As Integer   '// 한 셀씩 변하는 변수 지정
    Dim endRow As Integer   '// 최대 Row 수 구하는 변수 지정
    Dim cnt, Max_Cnt As Integer
    Dim oldTime As Single   '// 걸린 시간 구하는 변수 지정
    Dim rngAll As Range     '// D열의 모든 문자를 넣을 변수
    Dim rngC As Range       '// D열의 각셀을 넣을 변수
   
    oldTime = Timer     '// 시간 변수 설정, 필요없으면 콤마(,)로 disable
    Application.ScreenUpdating = False              '화면 업데이트 (일시)정지
   
    rngCh = "A"         '// 검사할 열
    endRow = Cells(Rows.Count, rngCh).End(3).Row
    rngT = "B"          '// 결과를 뿌려줄 열
    cnt = 1             '// 초기 카운트
    Max_Cnt = 1         '// 최대값 구하는 초기값

    '------------------- 연속되는 값 증가 구하는 함수식 --------------------------
    For i = 1 To endRow - 1
        If Cells(i, rngCh).Value = Cells(i + 1, rngCh).Value Then
            Cells(i + 1, rngT).Value = cnt + Cells(i, rngT).Value
        Else
            Cells(i + 1, rngT).Value = 1
        End If
        Cells(i, 4).Value = Cells(i, rngCh).Value   '// A열을 D열에 모두 복사 숫자4는 D열을 의미
    Next i
   
    '------------------- D열의 중복값 모두 제거 및 오름차순 정렬 ----------------------
    Set rngAll = Range("D2", Cells(Rows.Count, "D").End(3))  'D열 데이터영역을 변수에
    For Each rngC In rngAll                               'A열 각셀을 순환
        cnt = WorksheetFunction.CountIf(rngAll, rngC)   '각셀의 countif 값을 변수에
        If cnt > 1 Then                                        '만약 같은 이름이 1개 이상이면
            rngC.Resize(, 1).ClearContents            '그 열의 데이터를 삭제
        End If
     Next rngC

    Range([D2], Cells(Rows.Count, "D").End(3)).Sort key1:=Range("D2"), order1:=xlAscending  '오름차순 정렬
   
    '--------------------- 값의 변수 전체에 대한 연속 최대값 구하기 ----------------------
    Columns("E:E").EntireColumn.ClearContents   '// 값을 산출할 열 전체를 초기화
    For Each rngC In rngAll
        For i = 1 To endRow - 1
            If rngC.Value = Cells(i, rngCh) Then
                If Max_Cnt <= Cells(i + 1, rngT).Value Then     '// 최대값 구하는 조건
                   Max_Cnt = Cells(i + 1, rngT).Value
                   rngC.Offset(0, 1).Value = Max_Cnt
                   rngC.Offset(0, 1).HorizontalAlignment = xlCenter '// 가운데 정렬
                   rngC.HorizontalAlignment = xlCenter
                End If
            End If
        Next i
        Max_Cnt = 1     '// 최대값 초기화
    Next rngC
   
    Set rngAll = Nothing     '개체변수 초기화(메모리 비우기)
    Set rngC = Nothing
 
    'MsgBox "총 " & Format(Timer - oldTime, "#0.00") & " : 초 소요"

End Sub

첨부한 파일을 엑셀파일에서 활용하면 됩니다.

원하는 형태로 약간 수정해서 사용하면 됩니다.

연속중복값계산.vbs

[VBA] 연속되는 값의 몇번이나 나왔는지의 최대값 구하기

연속되는 값의 최대값 구하는 VBA 수식을 만들어봤습니다.

조건이 없는 최대값을 구하는 함수는 Application.Max 함수를 호출해서 구하면 쉽게 구해집니다.

조건이 있는 경우는 DMax 함수를 사용하면 되는 거 같은데 이건 아직 못해봤구요.

일단 허접하게 구현을 해봤습니다.

Sub MAX_Duplicate_Cnt()
    Dim rngCh, rngT           '// 입력할 열 글자
    Dim i As Integer   '// 한 셀씩 변하는 변수 지정
    Dim endRow As Integer   '// 최대 Row 수 구하는 변수 지정
    Dim Cnt, Max_Cnt1, Max_Cnt2 As Integer
    Dim oldTime As Single   '// 걸린 시간 구하는 변수 지정
   
    oldTime = Timer     '// 시간 변수 설정, 필요없으면 콤마(,)로 disable
    rngCh = "B"         '// 검사할 열
    endRow = Cells(Rows.Count, rngCh).End(3).Row
    rngT = "C"          '// 결과를 뿌려줄 열
    Cnt = 1             '// 초기 카운트
    Max_Cnt = 1

    For i = 1 To endRow - 1
        If Cells(i, rngCh).Value = Cells(i + 1, rngCh).Value Then
            Cells(i + 1, rngT).Value = Cnt + Cells(i, rngT).Value
           
            '// 아래는 같은 값을 가진 연속된 개수의 최대값을 구하는 수
            If Cells(i + 1, rngCh).Value = "O" Then
                If Max_Cnt1 < Cells(i + 1, rngT).Value Then
                    Max_Cnt1 = Cells(i + 1, rngT).Value
                End If
            Else
                If Max_Cnt2 < Cells(i + 1, rngT).Value Then
                    Max_Cnt2 = Cells(i + 1, rngT).Value
                End If
            End If
           
        Else
            Cells(i + 1, rngT).Value = 1
           
        End If
    Next i
   
    Cells(8, "F").Value = Max_Cnt1
    Cells(9, "F").Value = Max_Cnt2
 
    MsgBox "총 " & Format(Timer - oldTime, "#0.00") & " : 초 소요"

End Sub

처리결과 화면은

하지만 구해야 할 값이 딱 2개만 있는 경우가 아니라면 최대값은 수식으로 넣도록 하고 필터를 걸어서 확인하는 방법이 더 좋을 수도 있다고 봅니다.

서로 다른 모든 변수들을 자동으로 찾아서 계산한다음에 넣는 방법은 아직 모르겠네요..

첨부파일은

연속중복검사.xlsm

[VBA응용] VLookup VBA 이용한 예제 1

네이버 지식IN 사이트에 올라온 것이 있어서 이것을 한번 구현해 봤습니다.

질문 : 이곳 눌러보세요

날짜 값이 0 인 경우에 1900-01-00 으로 표시가 되는데 이걸 가져오면서 아예 안가져왔으면 좋겠다고 하는 내용이라 상황에 맞게 구현을 해봤습니다.

아래 그림을 보시면 테이블 구간 설정만 하고 몇번째 열의 값을 가져올 것인지, 어디에 뿌려줄 것인지만 지정하면 간단하게 끝나도록 구현된 VBA 코드입니다.

VLookup_VBA-01.vbs

지식인샘플_VLOOKUP_VBA.xlsm

VLOOKUP_VBA_modify.xlsm

파일이 필요하신 분은 매크로가 들어있는 엑셀파일을 다운로드 받으면 되구요.

그냥 VBA 소스가 필요하신 분은 위의 vbs 파일을 받으면 됩니다.

세세한 VBA 함수 등을 알고 싶으면 http://rosa0189.blog.me/ 사이트 가셔서 검색창에서 검색해서 원하는 VBA 함수나 기본지식을 같이 활용하시면 좋습니다.

IF문의 조건문을 충족하는가? 충족하지 않는가에 따라 다른 결과를 보여줍니다.

[VBA기초] 공백제거

엑셀을 다루다보면 첫번째 셀만 공백을 제거하고 싶을 때가 있습니다.

보통은 Trim 함수를 사용하면 제거가 되는데요.

위 엑셀은 Trim 함수를 써도 첫번째 공백이 제거가 되지 않네요.

시스템에서 가져온 데이터들이 보통 이런 경우들이 많은데요.

이런 경우에는 어떻게 해결할까요?

바로 아스키코드 값을 알아낸 다음에 셀의 첫번째 문자열의 값을 알아내는 겁니다.

Sub 첫문자열공백제거()
    Dim rngTarget As Range
    Dim rngC As Range
    Dim sName  As String
   
    ActiveCell.Select     '// 현재 커서가 있을 셀 선택
    Set rngTarget = Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column).End(3))
   
    For Each rngC In rngTarget
        sName = Left(rngC.Value, 1)     '// 첫번째 문자열 추출
        'MsgBox Asc(sName)              '//첫공백의 아스키 값을 알아내고자 한다면...
        If Asc(sName) = 63  Or Asc(sName) = 32 Then   '//스페이스바의 아스키 값은 32
            rngC = Mid(rngC, 2, Len(rngC))
        ElseIf Asc(sName) < 65 Or Asc(sName) > 90 Then    '// 첫글자가 영문자 대문자가 아닌지 검사
            rngC = UCase(sName) & Right(rngC, Len(rngC) - 1)
            '// 첫글자를 영문대문자로 변경 처리
        End If
    Next
   
End Sub

공백제거.vbs

위 VBA 함수를 이용하여 MsgBox Asc(sName) 를 활성화하여 공백의 값을 알아냅니다.

스페이스바의 아스키 값은 32 이더군요. (http://link2me.tistory.com/222 게시물 참조)

그런 다음에 'MsgBox Asc(sName) 로 처리하고 나서 F5 를 누르면 됩니다.

아니면 단축키 매크로 만들면 되구요.

첫 문자열 공백제거를 위한 단축키를 만들어서 누르면 ActiveCell 이 있는 열 전체가 모두 공백이 제거 됩니다.

공백의 아스키 값을 알아낼 수 없었다면 힘들게 하나 하나 지우는 고생을 했을 수도 있고

강제로 Mid함수를 이용하여 해당 행만 업데이트 할 수 있습니다.

VLookup 함수만 알아도 엑셀 다루는 업무가 엄청 편해지는데요.

VLookup 함수를 다루다보니 용량이 너무 큰 경우에는 파일 사이즈가 장난 아니게 커지는데다 속도 저하문제가 너무 심해서 이걸 해결할 목적으로 PC의 RAM(메모리)를 더 많이 늘렸었습니다. 그런데도 불구하고 함수를 많이 사용하면 역시나 속도 저하 문제가 심하고 응답도 늦더군요..

그래서 가능한 방법을 찾아보니 VLookup 함수 VBA 를 이용한 방법이 있더군요. 사용해보니 너무 편하고 좋네요.

속도저하 문제도 해결되고 용량문제도 해결됩니다.

VLookup 함수에 대한 이해가 부족하신 분은 http://link2me.tistory.com/29 게시물을 먼저 읽어보면 도움 되실 겁니다.

VBA 라고 하니까 너무 어렵다고 생각하고 아예 엄두도 안내시는 분들 많으실 겁니다.

제가 설명드린 거 찬찬히 보시고 첨부된 샘플 보시고 샘플만 몇가지 값만 수정하시면 금방 이해되시고 얼마든지 쉽게 누구나 다 이용하실 수 있다는 겁니다. 초보자 분들 용기를 내십시요

구하고자 하는 결과는 C열에 표시하는 것이라면.....

VBA 함수는 아래와 같습니다.

수정해서 사용할 부분이 어디인지 아시겠죠?

범위(Range) 지정하는 첫 시작셀 지점

테이블의 범위 지정

테이블에서 몇번째 열의 값을 가져올 것인가 하는 것 지정

가져온 걸 어디에 뿌려줄 것인가를 지정

* 다른 시트에 있는 자료를 table_array 로 할 경우 변수 선언 방법은

Set table_array = Worksheets("Table_array").Range("A2:C16") 처럼 직접 마지막 셀을 적어주는게 가장 확실하겠죠. 하지만 셀이 변경될 경우에는 잘못된 참조가 될 수도 있습니다.

이걸 방지하려면 Set table_array = Worksheets("Table_array").Range("A2:C" & Cells(Rows.Count,"C").End(3).Row) 라고 변수선언을 해주면 됩니다.

이렇게 하면 함수식이 전부 사라지고 바로 결과값이 나오므로 파일 사이즈가 커지지 않고 속도도 빠르게 처리됩니다.

1번은 시작셀 A2를 지정했고, 중간에 또 나오는 값 A가 있는데 이것도 같은 열의 값이어야 합니다.

2 번에 보는 바와 같이 같은 sheet 내에서 처리하는 방법, 다른 sheet 에 있는 걸 처리하는 방법, 다른 파일에서 가져오는 방법을 다 표기해두었습니다. 다른 파일에 있는 걸 가져오려면 반드시 Ctrl + O 로 파일을 열어서 가져와야 합니다.  

(엑셀을 분리하여 띄우는 방법으로 하면 참조가 안될 수 있습니다)

첨부된 vba 된 확장자 파일을 다운로드 받아서 텍스트 에디터로 여세요.
그리고 엑셀에서 Alt + F11 키를 누르세요. 그러면 아래와 같은 화면이 나타납니다. 

텍스트 에디터로 연 코드를 복사하여 여기에 붙여넣기를 하시면 됩니다.

이렇게 하시면 VLoolup 함수만 사용해서 하는 것보다 훨씬 속도면에서 빠릅니다.

단, 주의 사항은 잘못지정하면 되돌리기를 할 수 없다는 점을 명심하셔야 합니다.

표시될 결과값을 잘못 열을 지정하면 기록된 값이 순식간에 새로운 결과값으로 업데이트되고 되돌릴 수가 없어집니다.

처음에 하실 때에는 반드시 백업파일을 하나 만드신 다음에 하시기 바랍니다.

함수 몇가지와 더불어 VLookup 함수 다룰 때 VBA 를 이용하면 편하므로 한번 이용해보세요. 

VLookup_VBA_code.vbs

Vlookup_VBA_sample.xlsm

이상으로 VLookup 함수를 VBA를 이용하여 하는 방법에 대해 알아봤습니다.