무성의한 블로그

매크로 처음하시는 분들 참고하시라고 올려봅니다. 

아래 주소의 첨부 파일을 참조하세요. 

수입품_최종가격_계산표1.xlsm

Sub goCalcMoney()

'관세율

    tradeTaxRate = Cells(2, 2)

    addTaxRate = Cells(3, 2)

    moneyRate = Cells(4, 2)

    Range(Cells(13, 2), Cells(21, 7)).Value = 0

    k = 2

    Do While k < 8

        goodsMoney = Cells(8, k)

        InType = Cells(6, k)

        If goodsMoney < 1 Or goodsMoney = "" Then

        Else

            transFee = Cells(9, k)

            taxFee = Cells(10, k)

            weightAll = Cells(11, k)

            '1차 합계

            totalDallor = goodsMoney + transFee + taxFee

            sumKoreaWon = totalDallor * moneyRate

            Cells(13, k) = sumKoreaWon

            '과세운임

            i = 2

            Do While i < 999

                startWeight = Cells(i, 16)

                If startWeight < weightAll Then

                    i = i + 1

                Else

                    If sumKoreaWon > 200000 Then

                        transTaxFee = Cells(i - 1, 19).Value

                        Cells(14, k).Value = transTaxFee

                    Else

                        transTaxFee = Cells(i - 1, 18).Value

                        Cells(14, k).Value = transTaxFee

                    End If

                    i = 999

                End If

            Loop

            '과세기준

            standardTax = sumKoreaWon + transTaxFee

            Cells(15, k) = standardTax

            '관세

            If standardTax < 150000 Or InType = "목록" Then

                afterTax = sumKoreaWon

                afterAddTax = sumKoreaWon

                tradeType = "비과세"

            Else

                afterTax = standardTax * (1 + (tradeTaxRate / 100))

                afterAddTax = afterTax * (1 + (addTaxRate) / 100)

                tradeType = ""

            End If

            Cells(16, k) = afterTax

            Cells(17, k) = afterAddTax

            Cells(12, k) = tradeType

            '운송비

            i = 4

            Do While i < 999

                '몰테일 배송비

                mstartWeight = Cells(i, 10)

                If mstartWeight < weightAll Then

                    i = i + 1

                Else

                    mTransFee = Cells(i, 11).Value

                    i = 999

                End If

            Loop

            i = 4

            Do While i < 999

                '이하넥스 배송비

                estartWeight = Cells(i, 10)

                If estartWeight < weightAll Then

                    i = i + 1

                Else

                    eLTransFee = Cells(i, 13).Value

                    eNTransFee = Cells(i, 14).Value

                    i = 999

                End If

            Loop

            If mTransFee > eLTransFee Then

                If eLTransFee > eNTransFee Then

                    lastTransFee = eNTransFee

                    feeSource = "이하넥스 뉴저지"

                Else

                    lastTransFee = eLTransFee

                    feeSource = "이하넥스 LA"

                End If

             ElseIf mTransFee > eNTransFee Then

                lastTransFee = eNTransFee

                feeSource = "이하넥스 뉴저지"

             Else

                lastTransFee = mTransFee

                feeSource = "몰테일"

             End If

             wonLastTF = lastTransFee * moneyRate

             Cells(18, k) = wonLastTF

            If standardTax < 150000 Or InType = "목록" Then

                 Cells(19, k) = afterAddTax + wonLastTF

                 Cells(21, k) = afterAddTax - sumKoreaWon

            Else

                 Cells(19, k) = afterAddTax + wonLastTF - transTaxFee

                 Cells(21, k) = afterAddTax - sumKoreaWon

            End If

                 Cells(20, k) = feeSource

        End If

        k = k + 1

    Loop

End Sub

앞서 올린 매크로는 폴더에서 파일리스트를 읽어와서 엑셀시트에 뿌리는 기능입니다. 

오늘은 엑셀 시트에 뿌려진 파일을 하나씩 여는 기능을 소개합니다. 

엑셀 시트를 열고 첫번째 시트의 시트명과 A1 셀의 값을 읽어서 복사하고 시트 2에 붙이고 다시 닫는 기능입니다.

Sub testtt()

    '변수 선언 integer 는 32767 까지의 값만을 지원한다.

    Dim i As Integer

    Dim fileCnt As Integer           ' 파일의 수

    Dim sNo As Integer          ' 처리한 시트 수

    Dim cellPnt As Integer

    Dim f_name As String        '읽고자 하는 파일명

    Dim file_name As String      '파일명 전체

    '변수 기본값 할당

    i = 9           ' 첫 파일명이 아홉번째 줄에 있음.

    cellPnt = 2     ' 두번째 줄부터 써야 함.

    '처리할 파일의 갯수

    fileCnt = Sheets(1).Cells(8, 5).Value

    '매크로 파일명을 기록해 둡니다.

    orgBookName = ActiveWorkbook.Name

    ' 시트를 새로 만들어서 두번째 시트로 저장함. 시트명은 일자+시분초

    Sheets.Add after:=Sheets(1)

    Sheets(2).Name = Date & Hour(Time) & Minute(Time) & Second(Time)

    '반복하며 파일 처리 함

    ' 폴더열기 기능에서 파일을 읽어서 1번 시트의 9번째 위치부터 적었습니다.

    Do While i < fileCnt + 9

        sNo = 1

        '파일열기

        d_name = Sheets(1).Cells(i, 2).Value

        f_name = Sheets(1).Cells(i, 3).Value

        file_name = d_name + "\" + f_name

        Dim fs, f

        Set fs = CreateObject("Scripting.FileSystemObject")

        Set f = fs.GetFile(file_name)

        '시트 수 만큼 반복하며 확인할 것

            Workbooks.Open Filename:=file_name

        Workbooks(f_name).Activate

   '시트를 숨기기 해둔 상태라면 읽지 못합니다. 그래서 숨김여부를 먼저 체크합니다.

        If Sheets(1).Visible = xlSheetVisible Then

            Sheets(1).Select

            sName = Sheets(1).Name

            cValue = cells(1,1).value

            '확인된 시트명을 결과시트에 적기

            Workbooks(orgBookName).Activate

            Sheets(2).Activate

            ActiveSheet.Cells(cellPnt, 1).Value = i - 8 '번호 적어주기

            ActiveSheet.Cells(cellPnt, 2).Value = sName '시트명 가져오기

            ActiveSheet.Cells(cellPnt, 3).Value = cValue '시트명 가져오기

            cellPnt = cellPnt + 1

        End If

        sNo = sNo + 1

    '파일 닫기, 열었던 파일을 경고창 없이 저장 없이 종료합니다. 

    Application.DisplayAlerts = False

    Workbooks(f_name).Close SaveChanges:=False

    i = i + 1

    Loop

    MsgBox ("작업을 완료하였습니다.")

End Sub

엑셀 시트에서 파일폴더를 열고 해당 파일 폴더와 하위 폴더의 파일들을 읽어오는 매크로입니다. 

업무 중에 필요한 부분이라 만들었습니다. 

엑셀 매크로 작성 방법은 엑셀에서 보기->매크로기록 기능을 사용해서 기본적인 기능을 확인한 후 필요한 부분을 개선하는 방식으로 했습니다. 

또 추가적으로 필요한 부분은 인터넷에서 검색하여 추가했습니다. 

필요하신 분은 참조해서 사용하세요. 

참고로 시트의 D4열에 필터 값을 입력해야 합니다. 

*.xls* 등의 형식으로 입력하면됩니다. 

Sub getFolder()

    '각종 변수 선언

    Dim strPath As String

    Dim strNm As String

    Dim i As Integer

    Dim fdFolder As FileDialog

    Dim lngCount As Long

    ' 현재 있는 데이터를 모두 삭제해야 함.

    ' 첫번째 시트에서 작업을 합니다.

    Sheets(1).Activate

    ActiveSheet.Range("d3").Value = ""

    ActiveSheet.Range("b9:f10000").Value = ""

    ActiveSheet.Cells(8, 6).Value = 9

    '서브폴더의 내용을 가져옴

    ' folderspec에는 폴더 주소가 기재됩니다.

    Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)

    With fdFolder

        .Title = "검색할 폴더를 선택 하세요"

        If .Show = -1 Then

            Range("d3") = .SelectedItems(1) '선택한 폴더명을 A3 셀에 저장

            folderspec = Range("d3").Value

            getSubFolder (folderspec)

        End If

    End With

End Sub

'하위폴더를 조회하는 기능입니다. 

Sub getSubFolder(folderspec)

    Dim result As String

    Dim strFilter As String

    Dim Msg As String

    Dim strDir As String

    Dim r As Long

    strDir = Range("d3").Value

    If strDir = "" Then

        MsgBox (" 선택된 폴더가 없습니다. 폴더를 선택하세요.")

        Exit Sub

    End If

    r = 8

    Sheets(1).Cells(r, 2) = "폴더명"

    Sheets(1).Cells(r, 3) = "파일명"

    Sheets(2).Range("a1:d1").Font.Name = "Arial"

     '이 소스는 인터넷에서 가져온것입니다. 

    r = r + 1

    If Trim(Right(strDir, 1)) <> "\" Then strDir = strDir & "\"

    strFilter = Range("d4").Value

    result = sRetrieve(strDir, strFilter, r)

    '여기까지.

End Sub

     '이 소스는 인터넷에서 가져온것입니다. 

Private Function sRetrieve(sPath As String, strFilter As String, r As Long) As String

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set dDirs = fs.getFolder(sPath)

    For Each dDir In dDirs.SubFolders

        sRetrieve = sRetrieve(dDir.Path, strFilter, r)

    Next

    For Each fFile In dDirs.Files

        If fFile.Name Like strFilter Then

            Sheets(1).Cells(r, 2) = fFile.parentfolder.Path

            Sheets(1).Cells(r, 3) = fFile.Name

            r = r + 1

        End If

    Next

    Set fs = Nothing

End Function

엑셀을 사용해서 색상표를 추출하는 매크로 입니다 .

사무실에서 필요해서 간단하게 만들었습니다. 

colortest.xlsm

Sub colorTest()

    ' 기본값 세팅

    Cells(1, 2) = "Red"

    Cells(2, 2) = "Green"

    Cells(3, 2) = "Blue"

    Cells(1, 4) = "RGB 값"

    Cells(1, 5) = "색상"

    ' 소수점 이하는 반올림

    rVal = Round(Cells(1, 3), 0)

    gVal = Round(Cells(2, 3), 0)

    bVal = Round(Cells(3, 3), 0)

    '반올림한 값을 다시 적어줌

    Cells(1, 3) = rVal

    Cells(2, 3) = gVal

    Cells(3, 3) = bVal

    Range(Cells(4, 1), Cells(4, 3)).Merge

    Cells(4, 1) = "* 소수점 이하 값은 반올림됩니다."

    Range(Cells(2, 4), Cells(256, 6)).Clear

    i = 1

    Do While i < 256

        nrVal = i * rVal

        If i * rVal > 255 Then

            nrVal = 255

        End If

        ngVal = i * gVal

        If i * gVal > 255 Then

            ngVal = 255

        End If

        nbVal = i * bVal

        If i * bVal > 255 Then

            nbVal = 255

        End If

        '값을 실제로 부여함.

        Cells(i + 1, 4) = nrVal & ", " & ngVal & ", " & nbVal

        Cells(i + 1, 5).Interior.Color = RGB(nrVal, ngVal, nbVal)

        '조건이 맞으면 작업 중지

        If (nrVal = 255 And ngVal = 255 And nbVal = 255) Then

            i = 256

        Else

            i = i + 1

        End If

    Loop

    Cells(5, 4).Select

    ActiveWindow.FreezePanes = True

End Sub