[VBA] 최대값 셀에 배경색 지정

각 줄에서 가장 큰 값에 노랑색으로 채우고 싶을 때 어떻게 하죠?

관련 VBA 코드입니다.

Max_BackColor.vbs

Option Explicit
Sub Max_BackColor()
    Dim r As Long     '// 각 행을 늘려갈 변수
    Dim rowsCnt As Long   '// 전체 행의 개수를 넣을 변수
    Dim MaxNum As Long  '// 열의 최대값 변수
    Dim rngC As Range       '// 열 변동 변수
    Dim rngC_All As Range  '// 열 범위 변수
   
    Application.ScreenUpdating = False
    '// 셀에 배경색이 지정되어 있는 걸 초기화
    With Range([B2], Cells(Rows.Count, "D").End(3)).Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    rowsCnt = Cells(Rows.Count, "A").End(3).Row
    For r = 2 To rowsCnt   '// 2행부터 마지막행까지 1씩 늘려나감
        Set rngC_All = Range(Cells(r, "B"), Cells(r, "D"))  '// 각행의 열범위 지정
        MaxNum = Application.Max(rngC_All)  '// 해당 행의 최대값
        For Each rngC In rngC_All
            If rngC = MaxNum Then
                rngC.Interior.ColorIndex = 6    '// 6 은 노란색
                Exit For
            End If
        Next rngC
    Next r
End Sub

찾는 내용이 포함된 셀의 행 가져오기 VBA

찾는 셀의 내용이 입력한 텍스트와 100% 일치하는 경우는 앞 게시물에서 다뤘구요.

지금 다루는 사항은 입력한 텍스트가 포함된 셀이 있는 경우만 찾아서 복사하라는 VBA 코드입니다.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngAll As Range
    Dim rngC As Range
    Dim Taget As String
   
    If Target.Address <> "$A$2" Or IsEmpty(Target) Then Exit Sub
    Application.ScreenUpdating = False      '// 화면 업데이트 중지
    Sheets("Sheet2").Range("A5").CurrentRegion.Offset(1).Clear   '// 기존 데이터를 전부 삭제
    Set rngAll = Sheets("data").Range("A1").CurrentRegion '// A1 열과 연결된 인접셀 영역
    Set rngC = rngAll.Columns(3) '// 전체범위에서 선택할 열 3은 C열
    Set rngAll = rngAll.Rows(2).Resize(rngAll.Rows.Count - 1) '// A2 행부터 범위 재지정

    With Sheets("Sheet2")  '// 해당 시트명 직접 입력, ActiveSheet 로 하면 됨

        If WorksheetFunction.CountIf(rngC, "*" & Target & "*") = 0 Then
            MsgBox " 찾는 자료가 없습니다! ", 64, "입력오류 "
            Exit Sub
        Else
            rngC.AutoFilter Field:=1, Criteria1:="*" & Target & "*", VisibleDropDown:=False
            '// Target 포함된 행만 선별
            rngAll.Copy .Cells(Rows.Count, "A").End(3)(2)
            '// 자동 필터된 값을 시트의 마지막 아래행에 복사하라
        End If
    End With
    rngC.AutoFilter  '// 자동필터 해제
    Columns.AutoFit  '// 열너비 자동 맞춤

    Set rngAll = Nothing  '// 변수 초기화
End Sub

의미파악 :

어떤 Sheet 인지를 직접 다 적어주면 다른 Sheet 에서 결과를 실행해도 원하는 결과를 찾을 수 있습니다.

굵은 글씨나 색상이 다르게 표시된 부분을 눈여겨 보면 됩니다.

Columns(3) 은 3번째 열에서 찾을 내용이 있을 경우이므로, 만약 다른 열에 있다면 이 부분 숫자를 변경하면 됩니다.

가져가서 수정해서 쓴다면 파란색 부분만 상황에 맞게 수정하면 나머지는 수정하지 않아도 동작할 것입니다.

Fetch of Finding Cell.vbs

계속 배우는 중이라 생각한대로 동작이 안되거나 확인이 필요하면 F8키를 눌러가면서 일일이 어떤 동작의 변화가 발생하는지 체크를 하면서 정리중입니다.

위의 코드는 F8키를 눌러가면서 하면 에러가 발생합니다.

아래처럼 A2 셀에 입력한 값을 지정하고 F8키를 눌러가면서 실행을 합니다.

무조건 복사하여 이용하는 것보다 어떻게 변화하고 움직이는지 도움이 되기 때문에 상황에 맞게 응용하여 사용할 수가 있게 됩니다.

Sub AutoFilter_Copy()

    Dim rngAll As Range
    Dim rngC As Range
    Dim Taget As String

    Dim fstRow As Range   '// 첫줄 복사하기 위한 범위 지정 변수

    Target = Sheets("Sheet2").Cells(2, 1).Value      '// 조건 검색어

    If IsEmpty(Target) Then Exit Sub

    Application.ScreenUpdating = False      '// 화면 업데이트 중지

    Set fstRow = Sheets("data").Range("A1")  '// 복사할 범위의 첫셀 지정

    Range(fstRow, fstRow.End(2)).Copy Sheets("Sheet2").Range("A5")  '// 첫줄을 복사하여 Sheet2의 A5에 복사

    Sheets("Sheet2").Range("A5").CurrentRegion.Offset(1).Clear   '// 기존 데이터를 전부 삭제
    Set rngAll = Sheets("data").Range("A1").CurrentRegion '// A1 열과 연결된 인접셀 영역
    Set rngC = rngAll.Columns(3) '// 전체범위에서 선택할 열 3은 C열
    Set rngAll = rngAll.Rows(2).Resize(rngAll.Rows.Count - 1) '// A2 행부터 범위 재지정

    With Sheets("Sheet2")  '// 해당 시트명 직접 입력, ActiveSheet 로 하면 됨

        If WorksheetFunction.CountIf(rngC, "*" & Target & "*") = 0 Then
            MsgBox " 찾는 자료가 없습니다! ", 64, "입력오류 "
            Exit Sub
        Else
            rngC.AutoFilter Field:=1, Criteria1:="*" & Target & "*", VisibleDropDown:=False
            '// Target 포함된 행만 선별
            rngAll.Copy .Cells(Rows.Count, "A").End(3)(2)
            '// 자동 필터된 값을 시트의 마지막 아래행에 복사하라
        End If
    End With
    rngC.AutoFilter  '// 자동필터 해제
    Columns.AutoFit  '// 열너비 자동 맞춤

    Set rngAll = Nothing  '// 변수 초기화
End Sub

빈행제거

엑셀에서 중간 중간 빈행이 많아서 이걸 지우고 싶을 때 사용하는 VBA 코드다.

선택된 열 기준으로 빈셀을 만나면 그 행 전체를 지우므로 빈셀 옆에 데이터가 있어도 지워진다.

VBA는 간단한 프로그램이므로 내가 생각하는 것으로 해결이 어려우면 역발상으로 반대로 되는 걸 고려하여 실행하면 쉽게 풀리기도 한다.

통상적으로 빈행 삭제는 뒤에서부터 앞으로 실행해야 한다.

Sub 빈행삭제()
    Dim i As Double
    Dim LastRow As Double
    Dim r As Double
      
    Application.ScreenUpdating = False      '// 화면 업데이트 (일시) 정지
    LastRow = Cells(Rows.Count, "B").End(3).Row  '// 조건을 설정할 행 지정

    For i = LastRow To 1 Step -1
        If Cells(i, "C").Value = "" Then
            Cells(i, "C").EntireRow.Delete
            r = r + 1
        End If
    Next i
  
    MsgBox "총" & r & "행 삭제"
   
End Sub

또다른 방법으로 하면 달랑 코드 한줄이면 된다.

코드설명 : Columns("C") 는 C열 전체를 선택하고, SpecialCells(4)는 공백인 셀인 경우 EntireRow.Delete 행전체를 삭제하라. 즉, C열에서 공백인 셀이 있으면 그 행을 삭제하라

Sub 빈행삭제()

    // C열에 빈셀이 존재하면 모두 지워라.
    Columns("C").SpecialCells(4).EntireRow.Delete
    '// (4)는 xlCellTypeBlanks
End Sub

시스템에서 가져온 데이터의 경우에는 공백처럼 보이는데 공백이 아니라면 그 행은 Asc (아스키코드) 값을 먼저 알아내야 한다.

AutoFilter를 이용한 셀 일치하는 Row 자동 가져오기 VBA

특정한 구분자를 넣으면 해당되는 것만 필터링 해서 가져오는 VBA 코드 입니다.

하는 방법은 필터링해서 가져오고자 하는 Sheet 를 선택합니다.

선택하고 나서 마우스 우클릭을 한 다음에 나오는 코드 보기를 누릅니다.

이런 창이 뜹니다. 여기에 아래 VBA Code를 붙여넣기 하고 나서 창을 닫으면 끝 입니다.

코드를 수정하고 싶으면 위 방법대로 코드를 보면서 수정하면 됩니다.

현재 부족한 부분은 work 시트에서 첫번째 머리글에 해당하는 것의 값과 서식만 복사해서 붙여넣는 걸 아직 처리를 못한 상태입니다. 나머지는 원하는 자료를 순식간에 가져오기가 됩니다.

첫줄 Private Sub Worksheet_Change(ByVal Target As Range) 를 다른 이름으로 변경하면 안되더라구요.

코드 설명은 A2 열의 값이 입력되면 가져오고 그렇지 않으면 동작되지 않도록 되어 있습니다.

완전자동필터VBA.vbs

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngAll As Range
    Dim rngC As Range
    Dim Taget As String

    If Target.Address <> "$A$2" Then Exit Sub
    If Target <> "" Then
        Application.ScreenUpdating = False      '// 화면 업데이트 (일시) 중지
        Range("A5").CurrentRegion.Offset(1).Clear    '// 기존 데이터를 전부 삭제
        Set rngAll = Sheets("work").Range("A1").CurrentRegion '// A1 열과 연결된 인접셀 영역
        Set rngC = rngAll.Columns(1) '// 전체범위에서 선택할 열 1은 A열
        Set rngAll = rngAll.Rows(2).Resize(rngAll.Rows.Count - 1)
        '// A2 행부터 범위 재지정
      
        With ActiveSheet  '// 해당 시트명 직접 입력
            rngC.AutoFilter 1, Target, , , False
             '// Target 만 필터링, 즉 Columns(1) 열에서 Target 과 일치하는 열만 필터링
             '// xlOr, xlAnd
             rngAll.Copy .Cells(Rows.Count, 1).End(3)(2)
             '// 자동 필터된 값을 연습 시트의 마지막 값이 들어있는 아래행에 복사하라
        End With
        rngC.AutoFilter  '// 자동필터 해제
        Columns.AutoFit  '// 열너비 자동 맞춤
     End if
End Sub 

그리고 아래 Code는 버튼을 누르면 A2 셀 값에 해당되는 조건에 맞는 것만 필터링해서 가져옵니다.

똑같은데 위에 있는 코드와 어떤 부분이 차이가 있는지 살펴보면 금방 아실 겁니다.

Sub AutoFilter_Copy()
    Dim rngAll As Range
    Dim rngC As Range
    Dim Taget As String

    Target = Cells(2, 1).Value      '// 조건 검색어

    If Target <> "" Then
        Application.ScreenUpdating = False      '// 화면 업데이트 (일시) 중지
        Range("A5").CurrentRegion.Offset(1).Clear   '// 기존 데이터를 전부 삭제
        Set rngAll = Sheets("work").Range("A1").CurrentRegion '// A1 열과 연결된 인접셀 영역
        Set rngC = rngAll.Columns(1) '// 전체범위에서 선택할 열 1은 A열
        Set rngAll = rngAll.Rows(2).Resize(rngAll.Rows.Count - 1)
        '// A2 행부터 범위 재지정
       
        With ActiveSheet  '// 해당 시트명 직접 입력
            rngC.AutoFilter 1, Target, , , False
            '// 현재 시트(ActiveSheet)에서  Target 만 자동 선별
            '// xlOr, xlAnd
            rngAll.Copy .Cells(Rows.Count, 1).End(3)(2)
             '// 자동 필터된 값을 시트의 마지막 값이 들어있는 아래행에 복사하라
        End With
        rngC.AutoFilter  '// 자동필터 해제
        Columns.AutoFit  '// 열너비 자동 맞춤
    End If
End Sub

색상별로 시간합계 구하기 (SumIF 함수 사용)

배경색상별로 합계를 구하는 VBA Code 입니다.

기존 자료에 비해서 코드가 더 최적화되어 결과를 산출하는 속도가 빠릅니다.

더 빠르게 최적화 하는 방법도 가능할 거 같은데 아직은 능력이 부족하여 ㅠㅠ

Option Explicit
Sub SameColor_SumIF()
    Dim rngC, rngT As Range    '// 각 셀을 넣을 변수
    Dim rngData, tempData As Range  '// 전체 데이터 영역을 넣을 변수
    Dim sumData As Range      '// Data 시트 합계를 낼 영역 변수
    Dim rngVariable As Range  '// 구분자 영역 변수
    Dim i As Integer
    Dim oldTime As Single       '// 걸린 시간 구하는 변수 지정
   
    oldTime = Timer     '// 시간 변수 설정
    Application.ScreenUpdating = False        '//화면 업데이트 (일시) 정지
    Set rngData = Range([B2], Cells(Rows.Count, "B").End(3))
    Set sumData = Range([B2], Cells(Rows.Count, "B").End(3))
    Set rngT = [D2]
    Columns("D:E").EntireColumn.Clear   '// 값을 산출할 열 전체를 초기화
   
    '-------------------- C열에 색상 및 색상값 복사 ---------------------------
    For Each rngC In rngData
        rngC.Offset(0, 1).Value = rngC.Interior.ColorIndex
        rngC.Offset(0, 1).Interior.ColorIndex = rngC.Interior.ColorIndex
    Next rngC
    '-------------------- C열 기준으로 색상 및 합계 구하기 --------------------
    Set tempData = Range([C2], Cells(Rows.Count, "C").End(3))
    For Each rngC In tempData
        Set rngVariable = Range(rngT, rngT.End(4))  '// 범위가 계속 변함
        '// COUNTIF(범위,조건) : 범위에서 조건에 맞는게 몇개인지 카운트하라
        If Application.CountIf(rngVariable, rngC) = 0 Then
            rngT.Offset(i) = rngC
            rngT.Offset(i).Interior.ColorIndex = rngC.Interior.ColorIndex
            rngT.Offset(i, 1) = Application.SumIf(tempData, rngC, sumData)
            i = i + 1
        End If
    Next rngC
    '--------------- 가운데 정렬, 선그리기, 시간표시, 내림차순 정렬 ----------------------
    With ActiveSheet   '// 현재 시트
        .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
    '---------------- D열 색상만 남기고 값은 지우기 -------------------------------------
    Columns(3).EntireColumn.Clear    '// 임시로 값을 복사했던 열 초기화
    Range(rngT, rngT.End(4)).ClearContents   '//D2 부터 내용 삭제
    '------------------ 개체변수 초기화(메모리 비우기) -----------------------------------
    Set rngData = Nothing

    Set rngVariable = Nothing

    Set sumData = Nothing   
    MsgBox "총 " & Format(Timer - oldTime, "#0.00") & " : 초 소요"
End Sub

SameColor_SumIF.vbs

SameColor_SumIF.xlsm

VBA Code 파일 첨부합니다.

색상 개수와 색깔 표시하기 (동일 시트) - CountIF 함수 이용

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

CountIF 함수를 사용해서 중복되지 않는 값과 몇번이나 들어간 것인지 산출하고 나서

내림차순 정렬을 한 다음에 색깔이 들어간 갯수만큼 다른 색으로 원 데이터에 색깔을 칠하고 VBA Code 입니다.

이 코드가 속도가 훨씬 더 빠릅니다.

Option Explicit
Sub CellCnt_Countif()
    Dim rngC, rngT As Range    '// 각 셀을 넣을 변수
    Dim rngData As Range        '// 전체 데이터 영역을 넣을 변수
    Dim rngVariable As Range  '// 구분자 영역 변수
    Dim i As Integer

    Set rngData = Range([A2], Cells(Rows.Count, "D").End(3))
    Set rngT = [G2]
    Columns("G:H").EntireColumn.Clear   '// 값을 산출할 열 전체를 초기화
   
    For Each rngC In rngData
        Set rngVariable = Range(rngT, rngT.End(4))
        '// COUNTIF(범위,조건) : 범위에서 조건에 맞는게 몇개인지 카운트하라
        If Application.CountIf(rngVariable, rngC) = 0 Then
            rngT.Offset(i) = rngC
            rngT.Offset(i, 1) = Application.CountIf(rngData, rngC)
            i = i + 1
        End If
    Next rngC
   
    With ActiveSheet   '// 결과를 표시할 Sheet 선택
        .Cells(1, "G").Value = "구분"
        .Cells(1, "H").Value = "횟수"
        '--------------- 가운데 정렬, 선그리기 ----------------------------
        .Range("G1").CurrentRegion.HorizontalAlignment = xlCenter
        .Range(.[H2], .Cells(Rows.Count, "H").End(3)).NumberFormat = "#,###" '// 셀서식 : 3단위 콤마
        .Range(.[G1], .Cells(Rows.Count, "H").End(3)).Borders.LineStyle = 1     '// 사용영역 선그리기
        .Columns(7).CurrentRegion.Sort .[H2], 2    '// 값을 내림차순으로 정렬
    End With
  
    '------------------ 색상 칠하기 -----------------------------------------------
    For Each rngC In Range("G2", Cells(Rows.Count, "G").End(3))
       Call ColSet(rngData, rngC, rngC.Offset(0, 1))
    Next rngC
      
    '------------------ 개체변수 초기화(메모리 비우기) -----------------------------
    Set rngData = Nothing
    Set rngVariable = 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

동일색상처리_Coutif.xlsm

CellsCnt_Countif.vbs

업체별 공급가액 합계 및 정렬 2 (SUMIF 함수 사용)

지난번에는 검사하는 로직이 너무 단순 무식한 방법이라 이번에는 COUNTIF 함수와 SUMIF 함수를 이용하여 가져오는 걸 해봤습니다.

VBA Code 입니다.

Option Explicit
Sub 업체별공급가합계()
    Dim rngC As Range           '// Data 시트 각 셀을 넣을 변수
    Dim rngData As Range        '// Data 시트 전체 영역 변수
    Dim sumData As Range      '// Data 시트 합계를 낼 영역 변수
    Dim rngT As Range           '// 결과 시트 변수
    Dim rngVariable As Range    '// 결과 산출 변수
    Dim i, j As Integer
    Dim oldTime As Single       '// 걸린 시간 구하는 변수 지정
   
    oldTime = Timer     '// 시간 변수 설정
    Application.ScreenUpdating = False        '// 화면 업데이트 (일시) 정지
    Set rngData = Range(Sheets("매출장").[B2], Sheets("매출장").Cells(Rows.Count, "B").End(3))
    Set sumData = Range(Sheets("매출장").[E2], Sheets("매출장").Cells(Rows.Count, "E").End(3))
    Set rngT = Sheets("업체별").[A2]    '// 결과를 도출할 영역 설정
    rngT.CurrentRegion.Offset(1).Clear
   
    For Each rngC In rngData
        Set rngVariable = Range(rngT, rngT.End(4)) 
        '// COUNTIF(범위,조건) : 범위에서 조건에 맞는게 몇개인지 카운트하라

          '// SUMIF(조건범위, 조건, 합계범위)
        If Application.CountIf(rngVariable, rngC) = 0 Then
            rngT.Offset(i) = rngC
            rngT.Offset(i, 1) = Application.SumIf(rngData, rngC, sumData)
            rngT.Offset(i, 2) = Application.SumIf(rngData, rngC, sumData) * 0.1
            rngT.Offset(i, 3) = Application.SumIf(rngData, rngC, sumData) * 1.1
            'rngT.Offset(i, 4) = Application.CountIf(rngData, rngC)     '// 중복횟수
            i = i + 1
        End If
    Next rngC
   
    With Sheets("업체별")   '// 결과를 표시할 Sheet 선택
        '--------------- 가운데 정렬, 선그리기 ----------------------------
        .Range("A1").CurrentRegion.HorizontalAlignment = xlCenter
        .Range(.[B2], .Cells(Rows.Count, "D").End(3)).NumberFormat = "#,###" '// 셀서식 : 3단위 콤마
        .UsedRange.Borders.LineStyle = 1     '// 현재시트 사용영역 선그리기
        .Range("A2").CurrentRegion.Sort key1:=Range("B2"), order1:=xlDescending  '// 내림차순 정렬
    End With
      
    MsgBox "총 " & Format(Timer - oldTime, "#0.00") & " : 초 소요"
End Sub

매출장_2.xlsm

FIND와 ISNUMBER 로 원하는 결과 도출

FIND(찾는값, 찾는 값이 들어간 셀,시작위치) = 찾는 값이 들어간 셀의 시작점 위치를 반환

  - FIND 함수는 대문자, 소문자를 구분하여 값을 찾습니다. 한글, 영문 구분없이 문자 하나를 1로 인식합니다. 

  - FINDB 함수는 대문자, 소문자를 구분하여 값을 찾는데, 영문 문자는 1, 한글 문자는 2로 인식합니다.

  - 대문자, 소문자 구분없이 찾고자 한다면 SEARCH 함수를 이용하면 됩니다.

ISNUMBER(식) : 식이 숫자이면 참, 아니면 거짓을 반환합니다.

IF함수는 IF(조건식,참,거짓) 입니다.

조건식에 IF(ISNUMBER(식),참,거짓) 으로 표시하면 원하는 결과를 찾을 수 있습니다.

=IF(ISNUMBER(FIND("유도등",B2)),"피난시설",IF(ISNUMBER(FIND("소화기",B2)),"소화시설",IF(FIND("감지기",B2),"경보시설","")))

수식이 간단하네요.

그런데 만약 데이타가 엄청 많다면 이런 함수식 많이 써주면 속도문제, 용량문제가 발생할 수 있습니다.

이럴 경우에는 아래 VBA Code를 사용하면 좋습니다.

Search_Character.vbs

Option Explicit
Sub Search_Character()
    Dim rngAll As Range         '// 검사할 구간 변수
    Dim rngTarget As Range      '//대상 범위 지정변수
    Dim rngC As Range
    Dim oldTime As Single       '// 걸린 시간 구하는 변수 지정
  
    Application.ScreenUpdating = False  '//화면 업데이트 일시 정지

      '// 이걸 지정해주어야 매우 빠르게 처리함
    oldTime = Timer     '// 시간 변수 설정
    Set rngAll = Range([B2], Cells(Rows.Count, "B").End(3))

      '// 검사할 열이 B열인 경우, B2열 시작점, 끝점은 자동감지
    Set rngTarget = Range([D2], Cells(Rows.Count, "D").End(3))

      '// 결과를 보여줄 열 범위 지정
    rngTarget.Clear    '// 셀 초기화
  
    For Each rngC In rngAll
        If InStr(rngC.Value, "유도등") > 0 Then
            rngC.Offset(0, 2).Value = "피난시설"
        ElseIf InStr(rngC.Value, "소화기") > 0 Then
            rngC.Offset(0, 2).Value = "소화시설"
        ElseIf InStr(rngC.Value, "감지기") > 0 Then
            rngC.Offset(0, 2).Value = "경보시설"
        Else
            rngC.Offset(0, 2).ClearContents
        End If
    Next rngC
  
    Set rngAll = Nothing '// 변수 초기화
    MsgBox "총 " & Format(Timer - oldTime, "#0.00") & " : 초 소요"
End Sub

예제 샘플 파일입니다.

FIND_ISNUMBER.xlsm

AutoFilter로 시트별로 분리 저장

구분자별로 필터를 사용하여 시트별로 분리 저장하고자 할 경우 사용하는 VBA Code 입니다.

여기서의 키포인트는 Range.AutoFilter 메서드 입니다.

expression.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown)

- Field : 목록의 맨 왼쪽 필드가 1번 필드

- Criteria1 : 찾을 조건,  공백 필드 조건은 "=" 사용, 공백필드 아닌 조건은 "<>", 지정하지 않으면 모든 필터

- Operator : 필터의 종류를 지정하는 XlAutoFilterOperator 상수 중 하나

-  Criteria2 : 두번째 찾을 조건

- VisibleDropDown : False이면 필터링된 필드에서 자동 필터 드롭다운 화살표를 숨김

                         True이면 필터링된 필드에서 자동 필터 드롭다운 화살표를 표시

Option Explicit
Sub AutoFilter_Sheet_Split()
    Dim rngAll As Range    '// 전체 범위 지정 변수
    Dim rngC As Range
    Dim i As Integer

    Application.ScreenUpdating = False    '// 화면 업데이트 (일시) 중지
    Set rngAll = Range("A1").CurrentRegion '// A1 열과 연결된 인접셀 영역
    Set rngC = rngAll.Columns(1) '// 전체범위에서 선택할 열 1은 A열
    Set rngAll = rngAll.Rows(2).Resize(rngAll.Rows.Count - 1)
    '// A2 행부터 범위 재지정

    For i = 2 To Worksheets.Count   '// 2번째 시트부터 전체 시트만큼 순환
        With Worksheets(i)  '// 해당 시트명, 2번째, 3번째,,,,
             rngC.AutoFilter 1, .Name, , , False     '// 숫자1은 A열 필터
             '// .Name 은 시트명 이름. 따라서 시트명 이름과 동일한 것을 필터함
             '// .Name 은 Worksheets(i).Name 을 의미
             rngAll.Copy .Cells(Rows.Count, 1).End(3)(2)
             '// 필터된 값을 해당 시트(Worksheets(i))의 마지막 값이 들어있는 아래행에 복사하라
        End With
    Next i
   
    rngC.AutoFilter     '// 자동필터 해제
    Application.ScreenUpdating = True

End Sub

Sub AutoFilter_Copy()
    Dim rngAll As Range
    Dim rngC As Range
    Dim CateName
   
    CateName = InputBox("구분자를 입력하세요")
    Application.ScreenUpdating = False      '// 화면 업데이트 (일시) 중지
    Set rngAll = Range("A1").CurrentRegion '// A1 열과 연결된 인접셀 영역
    Set rngC = rngAll.Columns(1) '// 전체범위에서 선택할 열 1은 A열
    Set rngAll = rngAll.Rows(2).Resize(rngAll.Rows.Count - 1)
    '// A2 행부터 범위 재지정
   
    With Worksheets("연습")  '// 해당 시트명 직접 입력
        rngC.AutoFilter 1, CateName, , , False     '// 숫자1은 A열 필터
         '// 현재 시트(ActiveSheet)에서 CateName 만 자동 선별
         rngAll.Copy .Cells(Rows.Count, 1).End(3)(2)
         '// 자동 필터된 값을 연습 시트의 마지막 값이 들어있는 아래행에 복사하라
    End With
       
   rngC.AutoFilter  '// 자동필터 해제
   Application.ScreenUpdating = True
End Sub

위 VBA Code 입니다. 필요하신 분은 받아가세요.

구분자별자동필터로분리.vbs

vbs 첨부파일은 텍스트에디터로 열어서
엑셀에서 Alt + F11 눌러서 나오는 VBA Editor 창에서
[삽입] - [ 모듈] 눌러서 생성되는 화면에다가
붙여넣기를 하면 됩니다.

조건을 만족하지 않는 행을 삭제하는 VBA Code

조건 : A행은 11개의 숫자로 이루어져 있는데 조건을 만족하지 않는 행(Row)은 삭제하라

Sub 행삭제()
    Dim i, r, Counter As Integer
    Dim rngAll As Range        '// 범위 전체 영역 변수

    Application.ScreenUpdating = False        '화면 업데이트 (일시) 정지
    Cells(2, "A").Select    '// 현재 어느셀에 위치하든 A2 셀을 선택하라
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    '// 시작행 A2, 마지막행 자동인식
    Counter = rngAll.Rows.Count

    For i = 1 To Counter
        If Len(ActiveCell.Value) <> 11  Or Not IsNumeric(ActiveCell.Value) Then 

            '// 현재 셀의 길이가 11이 아니거나 숫자가 아니면
            Selection.EntireRow.Delete     '//해당행 전체 삭제
            Counter = Counter - 1          '// 행이 삭제되어 전체행 수를 하나 줄임
            r = r + 1         '// 삭제된 행의 수를 카운트
        Else
            ActiveCell.Offset(1, 0).Select    '// 아래행으로 이동
        End If
    Next i
    Msgbox "총" & r & "행 삭제"
End Sub

조건불만족행삭제.vbs

찾는 글자색에 색상을 주는 FIND VBA

'하나를 하더라도 최선을'님이 만들어 주신 VBA Code 입니다.

찾고자 하는 특정 단어만 다른 색으로 변경하고 싶을 때

가령 팀장이라는 단어만 찾아서 색깔을 파란색으로 변경하고 싶다고 하면

FIND VBA 를 이용하여 단어를 찾아서 바로 글자색을 변경한다.

Characters(start, length)에서 start 는 시작 문자 번호이며 length는 글자 수

InStr 함수는 한 문자열 안에 특정 문자열이 처음으로 나타난 위치를 정수(Long) 값으로 반환

  - InStr(start, 검색되는 문자식, 찾을 문자식, compare)

  - start 를 지정하지 않으면 첫 문자에서 검색을 시작

  - start 와 compare 는 선택요소로 생략해도 된다.

  - 반환할 위치가 없으면(찾을 문자식이 없으면) 0 을 반환한다. 따라서 IF 조건문에서 활용되기도 한다.

Option Explicit
Sub Character_ColorSet()
    Dim rngTarget As Range     '//대상 범위 지정변수
    Dim C As Range
    Dim FindText As String
    Dim strAddr As String
    Dim S As Integer
   
    Application.ScreenUpdating = False  '//화면 업데이트 일시 정지
    Set rngTarget = ActiveSheet.UsedRange
    'Set rngTarget = Range([A1], Cells(Rows.Count, "C").End(3))
    '// End(3) 은 End(xlUp), 데이터가 있는 마지막행까지 자동으로 찾음
   
    FindText = InputBox("검색할 문자 입력") '//검색할 문자를 변수에 넣음
   
    With rngTarget
        .Font.Bold = False
        .Font.ColorIndex = xlAutomatic
        Set C = .Find(what:=FindText, lookat:=xlPart)
       
        If Not C Is Nothing Then
            strAddr = C.Address '// 찾은 셀의 주소를 변수에 넣음
            Do
                S = 1
                Do
                    With C.Characters(Start:=InStr(S, C, FindText), Length:=Len(FindText)).Font
                          '.Bold = True   '// 굵은 글씨로 표시하고 싶으면
                           .Color = vbBlue '// 글자색 표시, vbGreen 녹색 vbRed 빨간색
                    End With
                    S = InStr(S, C, FindText) + Len(FindText)
                Loop While InStr(S, C, FindText)
                Set C = .FindNext(C) '// 다음 찾은 데이터를 변수에
            Loop While Not C Is Nothing And strAddr <> C.Address
            '// 검색 일치하지 않거나 처음 찾은 셀이 아닐때까지 무한 반복
        End If
   
    End With
   
    Set rngTarget = Nothing '// 변수 초기화
End Sub

결과는 아래 보는 것과 같이 찾는 단어가 같은 셀에 여러번 들어가도 찾을 수 있다는 것입니다.

특정단어찾기VBA.xlsm

======================================================================

★ 여러 단어 검색하는 코드(하나를 하더라도 최선을 님이 작성한 코드)

Sub Character_ColorSet()
    Dim rngTarget As Range '//대상 범위 지정변수
    Dim C As Range
    Dim FindText As String
    Dim strAddr As String
    Dim S As Integer
   
    Application.ScreenUpdating = False  '//화면 업데이트 일시 정지
    Set rngTarget = ActiveSheet.UsedRange
    'Set rngTarget = Range([A1], Cells(Rows.Count, "C").End(3))
    '// End(3) 은 End(xlUp), 데이터가 있는 마지막행까지 자동으로 찾음

    FindText = InputBox("검색할 문자를 ,로 분리하여 입력(최대 3개)") '//검색할 문자를 변수에 넣음
    Dim V As Variant
    V = Split(FindText, ",")
    If UBound(V) > 2 Then MsgBox "최대 3개의 단어만 지원합니다.": End
   
    With rngTarget
        .Font.Bold = False
        .Font.ColorIndex = xlAutomatic
        Dim i As Integer
        For i = 0 To UBound(V)
            Set C = .Find(what:=V(i), lookat:=xlPart)
           
            If Not C Is Nothing Then
                strAddr = C.Address '// 찾은 셀의 주소를 변수에 넣음
                Do
                    S = 1
                    Do
                        With C.Characters(Start:=InStr(S, C, V(i)), Length:=Len(V(i))).Font
                        '.Bold = True   '// 굵은 글씨로 표시하고 싶으면
                        .Color = Choose(i + 1, vbBlue, vbRed, vbGreen) '// 글자색 표시, vbGreen 녹색 vbRed 빨간색
                        End With
                        S = S + InStr(S, C, V(i))
                    Loop While InStr(S, C, V(i))
                    Set C = .FindNext(C) '// 다음 찾은 데이터를 변수에
                Loop While Not C Is Nothing And strAddr <> C.Address
                '// 검색 일치하지 않거나 처음 찾은 셀이 아닐때까지 무한 반복
            End If
        Next
    End With
   
    Set rngTarget = Nothing '// 변수 초기화
End Sub

VBA 로 복사하면 보통 값만 복사되는데 글자색도 같이 넣는 방법에 대한 팁은

Application.CutCopyMode = 0

엑셀 작업을 하다보면 빈행을 숨기고 싶은 경우가 생깁니다.

하나 하나 지정하기 힘든데 이럴 경우에 한번에 숨기기가 가능한 VBA Code 입니다.

마지막 행(Row)은 A열 기준으로 잡은 것입니다.

검사하고픈 조건식이 들어있는 열은 B열 또는 C열인 경우입니다.

둘중에 어떤 것을 써도 결과는 동일합니다.

그리고 숨긴행을 다시 숨기기 취소하면 다 보이니까 잘못될까 걱정할 필요는 없구요.

Sub 빈행숨기기()
    Dim i As Long                    '// 변동되는 변수
    Dim endRow As Long        '// 마지막 행 변수

    endRow = Cells(Rows.Count, "A").End(3).Row    '// 값이 들어있는 마지막행을 자동인식
    For i = endRow To 2 Step -1        '// 마지막 행부터 거꾸로
        If (Cells(i, "B") = "" And Cells(i, "C") = "") Or Cells(i, "B") = 0 Or Cells(i, "C") = 0 Then
            Rows(i).EntireRow.Hidden = True     '// 빈행 숨기기
        End If
    Next i
End Sub

Sub 빈행숨기기1()
    Dim i As Long                    '// 변동되는 변수
    Dim endRow As Long        '// 마지막 행 변수

    endRow = Cells(Rows.Count, "A").End(3).Row    '// 값이 들어있는 마지막행을 자동인식
    For i = 2 To endRow        '// 검사할 행이 2행인 경우 2행부터 마지막행까지
        If (Cells(i, "B") = "" And Cells(i, "C") = "") Or Cells(i, "B") = 0 Or Cells(i, "C") = 0 Then
            Rows(i).EntireRow.Hidden = True     '// 빈행 숨기기
        End If
    Next i
End Sub

업체별 공급가액 합계 및 정렬 방법1

업체별 공급가액을 합친 금액을 자동 계산하는 VBA 코드입니다.

원본 데이터는 다른 시트에 있고 현재 시트에서 가져오고자 하는 걸 가져오는 것입니다.

이런 결과를 가져오구요.

아래는 VBA Code 입니다. F8키를 눌러서 버그가 있는지 일일이 점검해서 완벽하게 동작합니다.

Option Explicit
Sub 업체별공급가합계()

    Dim rngC As Range    '// 각 셀을 넣을 변수
    Dim rngAll As Range  '// 색상 전체 데이터 영역을 넣을 변수
    Dim cnt, i, j As Long
    Dim Sum_Cnt As Double   '// 상황에 따라 Long, Double 지정
   
    Application.ScreenUpdating = False        '화면 업데이트 (일시) 정지
   
    Cells(1, "A").CurrentRegion.Offset(1).Clear  '// 기존 데이터 삭제
   
    '-------------------- Sheets("매출장") B열을 복사 ----------------------------------
    For i = 2 To Sheets("매출장").Cells(Rows.Count, "B").End(3).Row
        Cells(i, "A").Value = Sheets("매출장").Cells(i, "B").Value
    Next i
  
    '-------------------  중복값 모두 제거 ----------------------------
    For i = 2 To Cells(Rows.Count, "A").End(3).Row          '// A열 각셀을 순환
        For j = i + 1 To Cells(Rows.Count, "A").End(3).Row
            If Cells(i, "A") = Cells(j, "A") Then
               Cells(j, "A").Delete Shift:=xlUp         '// 셀을 위로 밀면서 삭제
               j = j - 1                                '// 셀이 삭제되었으므로 변수 1을 빼줌
            End If
        Next j
    Next i

    '------------------- 같은 이름별로 공급가액 더하기 --------------------------------
    Sum_Cnt = 0
    Set rngAll = Range([A2], Cells(Rows.Count, "A").End(3))
    For Each rngC In rngAll
        For i = 2 To Sheets("매출장").Cells(Rows.Count, "B").End(3).Row
            If rngC.Value = Sheets("매출장").Cells(i, "B").Value Then
                Sum_Cnt = Sum_Cnt + Sheets("매출장").Cells(i, "E").Value   '//공급가액 열
                rngC.Offset(0, 1).Value = Sum_Cnt
            End If
        Next i
        rngC.Offset(0, 2).Value = rngC.Offset(0, 1).Value * 0.1   '// 부가세 10%
        rngC.Offset(0, 3).Value = rngC.Offset(0, 1).Value + rngC.Offset(0, 2).Value
        Sum_Cnt = 0
    Next rngC
   
    '--------------- 셀 서식지정 및 가운데 정렬, 선그리기 ----------------------------
    Range([B2], Cells(Rows.Count, "D").End(3)).NumberFormat = "#,###" '// 셀서식 : 3단위 콤마
    Range("A1").CurrentRegion.HorizontalAlignment = xlCenter
    ActiveSheet.UsedRange.Borders.LineStyle = 1     '// 현재시트 사용영역 선그리기
   
    '-------------------- 내림차순 정렬 (필요한 경우에만 하면 됨) -------------------------------
    With Range("A2").CurrentRegion
        .Sort key1:=Range("B2"), order1:=xlDescending
    End With
   
    '------------------ 개체변수 초기화(메모리 비우기) -----------------------------
    Set rngAll = Nothing
   
    MsgBox "작업완료"
   
End Sub

첨부파일 첨부하니 필요하신 분은 받아가세요.

매출장.xlsm

Number 를 문자(Text)로 한번에 변경

Sub NumToText()
    Dim Temp As Double
    Dim Selection As Range

    Dim rngC as Range

    Set Selection = Range([B2], Cells(Rows.Count, "B").End(3))  '//마우스로 지정하려면 앞에 콤마를
     '// 마우스가 지정하는 것이 아니라 범위를 직접 지정하고 싶은 경우
     '// Cells(Rows.Count, "B").End(3) 은 B열의 값이 들어있는 마지막 셀을 의미함
    For Each rngC In Selection  '//마우스로 구간 설정한 곳 전부
        If Not IsEmpty(rngC.Value) And IsNumeric(rngC.Value) Then  '// 빈셀이 아니고 숫자이면
            Temp = rngC.Value
            rngC.ClearContents
            rngC.NumberFormat = "@"   '// 텍스트 서식으로
            rngC.Value = CStr(Temp)
            If Len(rngC.Value) < 13 Then  '//바코드가 총 13자리인거 같아서
                Select Case Len(rngC.Value)
                    Case 9: rngC.Value = "0000" & cell.Value
                    Case 10: rngC.Value = "000" & cell.Value
                    Case 11: rngC.Value = "00" & cell.Value
                    Case 12: rngC.Value = "0" & cell.Value
                End Select
            End If
        End If
    Next rngC
End Sub

색상을 이용한 결과값 구하기

색상을 이용하여 결과를 도출하고자 하는 경우가 있을 겁니다.

RGB 색상은 아니고, ColorIndex 값을 가진 색상입니다.

색상을 이용하려면 색상의 값을 먼저 알고 있어야 합니다.

Sub ShowColorIndex()
    Dim i As Integer, j As Integer
    For i = 1 To 4
        For j = 1 To 14
           Cells(j, (i - 1) * 2 + 1).Value = (i - 1) * 14 + j
           Cells(j, i * 2).Interior.ColorIndex = (i - 1) * 14 + j
        Next j
    Next i
End Sub

글자색을 구하려면 Font.ColorIndex 를 사용하고요.

배경색을 구하려면 Interior.ColorIndex 를 사용합니다.

둘다 모두 색상은 같습니다.

1 ~ 8 번까지는 색상이 우리가 아는 black. white, red, green, blue, yellow, magenta, cyan 입니다.

vbBlack, vbWhite, vbRed, vbGreen, vbBlue, vbYellow, vbMagenta, vbCyan 등으로 값을 써주면서 알아낼 수도 있습니다.

점수가 90점 이상이면 빨간색으로 하고 싶다면

rngC.Font.ColorIndex = 3 또는

rngC.Font.Color=vbRed

로 써주면 됩니다

'------------- 동일 글자 개수 구하는 함수 -----------------------

' rngAll 은 대상범위 이므로 A2:H16 같은 범위를 넣어주게 되는 거구요.

' Col 은 해당 셀을 의미

Function Color_Cnt(rngAll, Col) As Long
    Dim rngC As Range
    Dim i As Long
    For Each rngC In rngAll
        If rngC.Font.ColorIndex = Col.Font.ColorIndex Then
            i = i + 1
            Color_Cnt = i
        End If
    Next rngC
End Function

색상 개수와 색깔 표시하기

동일한 값이 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파일 내용을 복사하여 붙여넣기 하면 됩니다.

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

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

convert TextNumber to Number

보통 시스템에서 뽑아낸 자료를 보면 숫자인데도 텍스트로 된 경우가 있다.

이런 경우에 일일이 다 변경하는 건 정말 짜증나는 일이다.

VBA 코드를 알면 정말 간단하게 해결할 수 있다.

Sub Convert_TextNumber_To_Number()
    Dim rngC As Range
    Dim rngTarget As Range

    Set rngTarget = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)

    On Error Resume Next
    For Each rngC In rngTarget
        'If IsNumeric(rngC) Then rngC = Val(rngC) '// 에러 발생함

        If IsNumeric(rngC) Then rngC =Format(rngC, "#")  '// 정상처리됨

    Next rngC

    Set rngTarget = Nothing
    MsgBox "작업완료"
   
End Sub

TextNumber_to_Number.vbs

Text2Number.xlsm

이 코드를 엑셀에서 Alt + F11 키를 누르면 나오는 창에서 삽입 - 모듈 을 누르세요.

그러면 창이 나오는데 거기에 붙여넣기를 합니다

그곳에서 F5키를 누르면 실행되고 변경된 결과를 순식간에 확인할 수 있습니다.

현재 시트 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