도움되는 블로그

이전 포스팅 바로가기

[엑셀 VBA 예제4] 기간별(날짜별) 합계 구하기

실전예제5.xlsm

Private Sub worksheet_change(ByVal Target As Range)

Dim i As Integer

Dim n As Integer

Dim m As Integer

If Not Intersect(Range("c2:c9"), Target) Is Nothing Then

'----------------------여기부터 범위가 1보다 클 경우

If Target.Count > 1 Then            '타겟의 범위가 1보다 크다면(바뀌는 값의 범위가 한개가 아니라면)

n =  Target.Row                    '값을 수정하는 범위의 첫 행 (가장 윗행)

m = n + Target.Count - 1            '값을 수정하는 범위의 마지막 행(첫 행 + 범위 크기 - 1)

For i = n To m                            '범위의 첫 행부터 마지막 행까지 반복

    Select Case Cells(i, 3).Value            '셀의 값을 조건으로 한 조건문

    Case 0                                        '값이 0이라면(없다면)

    Cells(i, 3).Interior.color = xlNone        '셀을 투명하게(초기화)

    Case Is < 300000                            '값이 300000보다 작다면

    Cells(i, 3).Interior.color = RGB(255, 0, 0)        'red 색상으로 변경

    Case 300000 To 10000000                '값이 300000과 10000000 사이라면

    Cells(i, 3).Interior.color = RGB(0, 255, 0)        'green 색상으로 변경

    Case Is > 10000000                        '값이 10000000보다 크다면

    Cells(i, 3).Interior.color = RGB(0, 0, 255)        'blue 색상으로 변경

    End Select

Next i                    '다음 셀에서 반복

Exit Sub                '프로시져 종료

else

End If

'-------------------------여기까지 범위가 1보다 클 경우

'-------------------------여기부터 범위가 1일경우(한개의 셀만 수정할 경우)

    Select Case Target

        Case 0

        Target.Interior.color = xlNone

        Case Is < 300000

        Target.Interior.color = RGB(255, 0, 0)

        Case 300000 To 10000000

        Target.Interior.color = RGB(0, 255, 0)

        Case Is > 10000000

        Target.Interior.color = RGB(0, 0, 255)

    End Select

End If

End Sub

실전예제4.xlsm

Sub example()

Dim sumdata()                '값을 넣을 배열 추가

Dim nrow As Long            '시작하는 셀의 행

Dim ncol As Long                '시작하는 셀의 열

Dim lastD As String             

Dim i As Integer   

Dim D as string

    nrow = 2                '시작하는 셀의 행

    ncol = 1                '시작하는 셀의 열

    i = 1                    '카운터(배열의 행을 추가하기 위한)

    lastD = Left(Cells(nrow, ncol).Value, 7)        '날짜 중복을 방지하기 위한 설정

        For nrow = 2 To Cells(2, 1).End(4).Row        '시작행 2부터 값이 있는 마지막 셀까지 반복

        D = Cells(nrow, ncol).Value         '날짜 값 변수에 넣기               

            If D <> lastD Then                '이전 날짜 값과 같지 않다면

            i = i + 1                            '카운터에 1을 더한다

            End If

                ReDim Preserve sumdata(1 To 2, 1 To i)    '배열 재선언(카운터만큼 열을 늘린다)

                sumdata(1, i) = D                '날짜값을 배열의 첫 값에 넣음

                sumdata(2, i) = sumdata(2, i) + Cells(nrow, ncol).Offset(0, 1)   '누적되는 액수를 두번째 칸에 넣음

                lastD = D                'lastD값 재생성

        Next nrow             '날짜가 변할때 까지 액수 누적 반복       

    Cells(1, 4).Resize(2, i) = sumdata        '배열을 셀에 집어넣기

End Sub

Public Function colorsum(rngcolor, rng As Range)   '함수 이름은 colorsum, 인수는 '지정색깔(rngcolor)', '합계범위(rng)'

Dim sum As Long  '구할 합계 sum 변수설정

Dim SearchColor as Long  '색깔 변수 설정

sum = 0  '합계 초기값 설정

SearchColor = rngcolor.Interior.color    '첫 번째 인수인 rngcolor에 지정된 셀의 색깔값을 SearchColor에 지정

For Each rngn In rng        '두 번째 인수인 rng의 범위 안에서 처음부터 끝까지 순환

If rngn.Interior.color = SearchColor Then    '해당 셀의 색깔이 rngcolor의 색깔과 같다면

sum = sum + rngn.Value            '합계에 해당 값을 더한다

End If

Next                '그 다음 셀으로 이동

colorsum = sum            '출력할 함수값 지정

End Function

Option Explicit                '변수가 선언(dim) 없이 사용되는 것을 방지

Sub example()

Dim b As Object

Dim c As Object

Dim d As Object

Dim wks As Worksheet

Dim stryear As String

Dim currrow As Integer

Dim currcol As Integer

Dim curval As Long

With ActiveWorkbook                            '해당 워크북에서

    For Each wks In Worksheets                '모든 워크시트를 순환

        If InStr(wks.Name, "20") <> 0 Then            '해당 워크시트의 이름에 20이 들어가면

                 With wks.Range("a1:z20")                                    'range 범위는 모든 값을 포함하는 범위로 설정

                      Set b = .Find("자산총계", lookat:=xlWhole)            '"자산총계" 값이 있는 셀을 찾는다

                        If Not b Is Nothing Then                    '"자산총계" 값이 하나라도 있다면

                        curval = b.Offset(1, 0).Value                'curval(변수)는 "자산총계" 셀 바로 아래의 셀 값으로 설정

                      End If

                 End With

stryear = Mid(wks.Name, InStr(wks.Name, "20"), 4)                    'stryear(변수)는 시트 이름에 포함된 년도값(20xx)

                  With COMP.Range("a1:z20")                    'COMP 시트에서 (Range 범위는 모든 값을 포함하는 범위)

                  Set c = .Find(stryear, lookat:=xlPart)            'stryear값을 포함하는 셀을 찾는다.

                       If Not c Is Nothing Then                    'stryear 값을 포함하는 셀이 하나라도 있다면

                        currrow = c.Row                    'currrow(변수) 값은 그 셀의 행값

                        End If

                   Set d = .Find("자산", lookat:=xlWhole)            '"자산"을 포함하는 셀을 찾는다

                    If Not d Is Nothing Then            

                     currcol = d.Column                        'currcol(변수) 값은 그 셀의 열값

                   End If

                  End With

COMP.Cells(currrow, currcol).Value = curval       '년도와 항목에 맞춰서 값을 집어넣는다         '

        End If

    Next wks                    '다음 시트로 넘어가기

End With

 MsgBox "입력 완료"

End Sub

실전예제1.txt

실전예제1.xlsm

Sub text_to_excel()

    Const loadf As Long = 2             '텍스트 파일 속에서 가져와야 하는 시작하는 행 위치

    Const loadt As Long = 99999            '텍스트 파일 속에서 가져와야 하는 마지막 행 위치보다 큰 값을 설정

    Dim strFileName As String              '텍스트 파일 이름 설정

    Dim objText As Object           '텍스트 문서 값 개체변수

    Dim i As Long                       '변하는 행값 변수

    Dim varValue As Variant           '엑셀에 입력되는 값

    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)

                             .Show              '파일피커 열기

        If .SelectedItems.Count = 0 Then        '아무것도 선택되지 않았을 경우 프로시저 종료

            Exit Sub

        Else

            strFileName = .SelectedItems(1)        '파일 이름 지정

        End If

    End With

    If Len(strFileName) > 0 Then                   '파일 이름의 길이가 0보다 크면 (파일이 존재하면)

        Set objText = CreateObject("Scripting.FileSystemObject").OpenTextFile(strFileName, _

        IOMode:=1, Create:=False, Format:=-2)           '지정된 이름의 파일을 열기

        For i = 1 To loadt                      '지정한 행 수 만큼 반복하기

            If Not objText.AtEndOfStream Then           '텍스트파일의 끝이 아니라면

            If i < loadf Then                            '행의 위치가 지정된 시작 행(loadf)보다 작다면

            objText.skipline                            '그 행을 뛰어 넘는다

            Else

                varValue = Split(objText.ReadLine, vbTab)         '텍스트파일의 한 행의 값을 탭으로 분리해서 가져온다    

'vbTab을 "," ";" " " 등으로 바꿔서 사용할 수 있다.

                Cells(Rows.Count, 1).End(3)(2).Resize(, UBound(varValue) + 1) = varValue        '셀에 텍스트파일 값을 넣기                  

            End If

            End If

        Next i

    End If

       objText.Close

    Set objText = Nothing

End Sub

Sub text_to_excel()

    Const loadf As Long = 2             '텍스트 파일 속에서 가져와야 하는 시작하는 행 위치

    Const loadt As Long = 99999            '텍스트 파일 속에서 가져와야 하는 마지막 행 위치보다 큰 값을 설정

    Dim strFileName As String              '텍스트 파일 이름 설정

    Dim objText As Object           '텍스트 문서 값 개체변수

    Dim i As Long                       '변하는 행값 변수

    Dim varValue As Variant           '엑셀에 입력되는 값

    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)

                             .Show              '파일피커 열기

        If .SelectedItems.Count = 0 Then        '아무것도 선택되지 않았을 경우 프로시저 종료

            Exit Sub

        Else

            strFileName = .SelectedItems(1)        '파일 이름 지정

        End If

    End With

    If Len(strFileName) > 0 Then                   '파일 이름의 길이가 0보다 크면 (파일이 존재하면)

        Set objText = CreateObject("Scripting.FileSystemObject").OpenTextFile(strFileName, _

        IOMode:=1, Create:=False, Format:=-2)           '지정된 이름의 파일을 열기

        For i = 1 To loadt                      '지정한 행 수 만큼 반복하기

            If Not objText.AtEndOfStream Then           '텍스트파일의 끝이 아니라면

            If i < loadf Then

            objText.skipline

            Else

                varValue = Split(objText.ReadLine, vbTab)         '텍스트파일의 한 행의 값을 탭으로 분리해서 가져온다

                Cells(Rows.Count, 1).End(3)(2).Resize(, 1) = varValue(1)        '셀에 텍스트파일 값을 넣기      '

            End If

            End If

        Next i

    End If

        objText.Close

  '(a2:a99999) 값은 평균 낼 데이터를 포함하는 범위

        Cells(2, 5).value = "=average(a2:a99999)"                'average 함수식을 셀(E5)에 집어넣는다

        Cells(2, 5).value = Cells(2, 5).value                         '출력된 함수값을 일반 형식의 값으로 바꾼다.

        Range("a2:a99999").Value = ""                                 '텍스트파일에서 추출한 데이터를 삭제한다

    Set objText = Nothing

End Sub