2021. 9. 1. 09:46

[Excel-VBA] URL에 해당하는 이미지 자동으로 읽어오는 함수

어디선가 줒어온 소스;;;

urlCol 이랑 대상 컬럼, 시작Row, 대상 컬럼 정도만 맞추고 한번 슥 돌려주면 알아서 읽어옴

' 귀찮아서 인터넷에서 긁어옴
Sub getPictureFromURL()

Dim URL As String '이미지 URL 처리용 변수
Dim r As Long '작업중인 행
Dim urlCol As Integer ' URL이 들어있는 컬럼 번호
Dim targetCol As Integer ' 그림을 넣은 target 컬럼 번호

urlCol = 3
targetCol = 4

' 처음 1행은 헤더가 있기 때문에 2번째 row부터 시작
r = 2
Do
    URL = Cells(r, urlCol).Value  '각 셀의 값을 URL에 변수에 넣음
    On Error Resume Next '에러 발생해도 다음코드 진행
    ActiveSheet.Pictures.Insert(URL).Select 'URL 주소에 있는 각 그림을 삽입함
    
    If Err <> 0 Then '만약 무언가 오류가 발견되면, 그냥 무시하고 다음 항목으로 넘어간다
        Err.Clear 
        On Error GoTo 0
        GoTo errHandler
    End If
    
    With Selection '선택된 그림에서 작업
        .ShapeRange.LockAspectRatio = msoTrue '가로세로 비율고정(false면 해제)
        .Left = Cells(r, targetCol).Left + 2  '사진 왼쪽위치
        .Top = Cells(r, targetCol).Top + 2  '사진 윗쪽 위치
        .Height = Cells(r, targetCol).Height - 4  '사진 높이
        .Width = Cells(r, targetCol).Width - 4  '사진 너비
    End With
    
errHandler:
    
    r = r + 1 ' 다음행 데이터를 확인
Loop Until Cells(r, urlCol) = vbNullString
' URL 값이 공백을 만나면 종료
End Sub
2021. 2. 22. 14:39

엑셀 Addin 작성시 툴바 및 메뉴 생성 / 제거 코드

엑셀에서 Addin을 작성할때, 엑셀의 툴바 및 툴바 버튼, 메뉴를 추가하기 위한 코드
- 모든 작업은 ThisWorkbook 개체에서 작업한다.
- 되도록이면 작업하기 전에 On Error Resume Next 를 걸어줘서 오류를 없애는 편이 나을 것임

- Workbook_AddinInstall 이벤트에 아래와 같은 코드 추가
    ' 툴바에 버튼 올리기
    Application.CommandBars.Add "툴바이름"
    Application.CommandBars("툴바이름").Visible = True
    Set btnCmd = Application.CommandBars("툴바이름").Controls.Add(msoControlButton)
    btnCmd.OnAction = "클릭시 실행할 모듈 상의 함수이름1"
    btnCmd.Caption = "버튼이름1"
    btnCmd.FaceId = 64   ' 버튼 아이콘
    btnCmd.Style = msoButtonIcon  ' 버튼 모양
    Set btnCmd = Nothing
   
    Set btnCmd = Application.CommandBars("툴바이름").Controls.Add(msoControlButton)
    btnCmd.OnAction = "클릭시 실행할 모듈 상의 함수이름2"
    btnCmd.Caption = "버튼이름2"
    btnCmd.FaceId = 104   ' 버튼 아이콘
    btnCmd.Style = msoButtonIcon  ' 버튼 모양
    Set btnCmd = Nothing

    ' 메뉴에 삽입하기
    Set cmdBar = Application.CommandBars("worksheet menu bar")
    With cmdBar.Controls.Add(Type:=msoControlPopup)
        .Caption = "상위메뉴이름"
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "메뉴항목이름1"
            .OnAction = "메뉴항목클릭시 실행할 모듈상의 함수 이름1"
            .BeginGroup = True   ' 새로운 가로선을 넣을지 여부
            .FaceId = 64             ' 메뉴상에 표시할 아이콘 번호
        End With
       
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "메뉴항목이름2"
            .OnAction = "메뉴항목클릭시 실행할 모듈상의 함수 이름2"
            .FaceId = 301
        End With
    End With
    Set cmdBar = Nothing


- 툴바 삭제시 Workbook_AddinUninstall 이벤트에 아래와 같은 코드 추가
    ' 툴바 삭제
    Dim cmdBar As CommandBar
   Application.CommandBars("툴바이름").Visible = False   ' 툴바이름은 위에서 생성한 툴바 이름임
   Application.CommandBars("툴바이름").Delete

   ' 메뉴 삭제
    Set cmdBar = Application.CommandBars("worksheet menu bar")
    cmdBar.Controls("상위메뉴이름").Delete
    Set cmdBar = Nothing

 

- 오피스 2016에서 돌려보니 가끔 오류도 나오고 오류는 안나는데 추가기능 쪽의 메뉴가 나오지 않는 현상이 발생하는 경우가 있음. 이때에는 Addin이 Open 될 때 메뉴를 추가해주고 BeforeClose 일때 메뉴를 삭제해주는 방법을 사용한다.

이 때, 화면에 메뉴가 두개씩 나오는 나오는 경우가 발생할 수 있기 때문에 Workbook_AddinInstall 함수에서 기존 버튼이 있는지 확인하는 과정이 필요하다

Private Sub Workbook_AddinInstall()
    ' 이거 추가한다고 엑셀 열때마다 오류가 나면 짜증나니 이렇게 호출
    On Error Resume Next
    ' 기존에 해당 버튼이 있는지 확인
    If Application.CommandBars("버튼명") Is Nothing Then
        Application.CommandBars.Add "버튼명"
        Application.CommandBars("버튼명").Visible = True
        Set btnCmd = Application.CommandBars("버튼명").Controls.Add(msoControlButton)
        btnCmd.OnAction = "호출함수"
        btnCmd.Caption = "버튼명"
        btnCmd.FaceId = 1394   ' 버튼 아이콘
        btnCmd.Style = msoButtonIcon  ' 버튼 모양
        Set btnCmd = Nothing
    End If
	
End Sub

' 열릴 때 마다 툴바가 추가되면, 지속적으로 버튼만 늘어나기 때문에
' (install 할 때 기존에 버튼이 있는지 확인하기 때문에 그럴 리는 없지만 보험용도)
' 닫을 때 툴바를 없애줌(MS에서 이렇게 하라고 하였음)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Workbook_AddinUninstall
End Sub

' 툴바가 자동으로 추가가 안되기 때문에 열릴때 마다 추가
Private Sub Workbook_Open()
    Workbook_AddinInstall
End Sub

 

 

2018. 4. 10. 18:25

VBA를 이용하여 엑셀의 선택 셀에 대한 대소문자 변경

MS 사이트에 있는 코드 긁어와서 한글 설명만 붙임


Sub ToggleCaseMacro(),

    Dim CaseRange As Range,

    Dim CalcMode As Long,

    Dim cell As Range,

,

    On Error Resume Next,

    ' 선택한 영역(셀이 하나 이상일 수 있음!)에 Text셀이 존재하는지 여부를 검사하는 함수,

    ' 선택영역과 선택영역의 Text셀이 중복되면 해당 영역을 반환. 없으면 Nothing 처리,

    Set CaseRange = Intersect(Selection, _,

        Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)),

    ,

    ' 일단 Error 무시,

    On Error GoTo 0,

    If CaseRange Is Nothing Then Exit Sub,

,

    ' 화면 갱신을 막아줌,

    With Application,

        CalcMode = .Calculation,

        .Calculation = xlCalculationManual,

        .ScreenUpdating = False,

        .EnableEvents = False,

    End With,

,

    ,

    ' 셀이 하나 이상일 수 있으니 모든 셀에 대해서 대문자면 소문자로, 소문자면 적절하게 변경하고 그 외의 경우는 대문자 처리함,

    For Each cell In CaseRange.Cells,

        Select Case cell.Value,

        Case UCase(cell.Value): cell.Value = LCase(cell.Value),

        Case LCase(cell.Value): cell.Value = StrConv(cell.Value, vbProperCase),

        Case Else: cell.Value = UCase(cell.Value),

        End Select,

    Next cell,

,

    ,

    ' 화면 갱신을 다시 진행,

    ' 이렇게 해야 화면에 변화하는게 안보이고 한번에 변경된거 같으면서 속도도 빠름,

    ' 의외로 새로 그리기 속도가 꽤 느리기 때문에 위의 갱신 막는것과 함께 같이 항상 써줘야 함,

    With Application,

        .ScreenUpdating = True,

        .EnableEvents = True,

        .Calculation = CalcMode,

    End With,

End Sub


2018. 4. 10. 18:05

엑셀 Addin 작성시 마우스 오른쪽 메뉴 생성 방법

MS쪽 사이트에 있는 코드를 그대로 가져와 설명만 붙여봄


Sub AddToCellMenu(),

    Dim ContextMenu As CommandBar,

    Dim MySubMenu As CommandBarControl,

,

    ' 중복 제거를 위해서 미리 메뉴를 삭제해 줌,

    Call DeleteFromCellMenu,

,

    ' CommandBars("Cell")로 지정하면 ContextMenu를 접근할 수 있음,

    Set ContextMenu = Application.CommandBars("Cell"),

,

    ,

    ' 내장되어 있는 메뉴를 추가(ID = 3 -> Save),

    ' 내장되어 있는 메뉴를 추가하기 위해선 아래의 한줄이면 끝,

    ' before는 순서,

    ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1,

,

,

    ' 1단짜리 메뉴 추가. 일반 툴바에 버튼 추가하는 것과 같은데 순서 지정하는 부분이 있음,

    ' OnAction에는 동작할 함수가, FaceId는 아이콘이, Caption의 경우 Text로 표시할 부분이, Tag에는 기타 정보가 들어감,

    ' 삭제시에 Tag정보를 바탕으로 버튼을 삭제할 수 있음,

    With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2),

        .OnAction = "'" & ThisWorkbook.Name & "'!" & "ToggleCaseMacro",

        .FaceId = 59,

        .Caption = "대문자/소문자/적절한 문자로 전환",

        .Tag = "My_Cell_Control_Tag",

    End With,

,

    ' Add a custom submenu with three buttons.,

    ' 서브메뉴가 있는 경우 추가 방법,

    ' 일단 메뉴를 하나 만들고, 그 아래 버튼을 넣는 방식,

    ' 메뉴를 추가할때 Type을 보면 msoControlPopup임. 버튼일 경우는 Type이 msoControlButton임,

    ' 일단 버튼을 만든 이후에는 일반 메뉴와 똑같음,

    Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3),

,

    With MySubMenu,

        .Caption = "문자메뉴",

        .Tag = "My_Cell_Control_Tag",

,

        With .Controls.Add(Type:=msoControlButton),

            .OnAction = "'" & ThisWorkbook.Name & "'!" & "UpperMacro",

            .FaceId = 100,

            .Caption = "대문자",

        End With,

        With .Controls.Add(Type:=msoControlButton),

            .OnAction = "'" & ThisWorkbook.Name & "'!" & "LowerMacro",

            .FaceId = 91,

            .Caption = "소문자",

        End With,

        With .Controls.Add(Type:=msoControlButton),

            .OnAction = "'" & ThisWorkbook.Name & "'!" & "ProperMacro",

            .FaceId = 95,

            .Caption = "적절한문자",

        End With,

    End With,

,

    ' 아래 명령어로 중간 구분자를 넣을 수 있음,

    ContextMenu.Controls(4).BeginGroup = True,

End Sub,

,

Sub DeleteFromCellMenu(),

    Dim ContextMenu As CommandBar,

    Dim ctrl As CommandBarControl,

,

    ' CommandBars("Cell")로 지정하면 ContextMenu를 접근할 수 있음,

    Set ContextMenu = Application.CommandBars("Cell"),

,

    ' Delete the custom controls with the Tag : My_Cell_Control_Tag.,

    ' 모든 콘트롤들을 보면서 Tag가 My_Cell_Control_Tag 인 항목을 찾아서 지워줌,

    ' 이렇게 하면 원하는 모든 걸 한번에 지울 수 있으니 이 방법을 쓰면 좋을 것임,

    For Each ctrl In ContextMenu.Controls,

        If ctrl.Tag = "My_Cell_Control_Tag" Then,

            ctrl.Delete,

        End If,

    Next ctrl,

,

    ,

    On Error Resume Next,

    ' 내장 기능에 대한 삭제는 아래와 같은 방법으로 사용,

    ContextMenu.FindControl(ID:=3).Delete,

    On Error GoTo 0,

End Sub,


2011. 3. 25. 10:28

엑셀에서 탭(워크시트)들을 알파벳순으로 정렬하는 방법

엑셀에 별도로 그런 기능은 제공하지 않고,
MS쪽에 보니 VB매크로를 줘서 돌려보니까 잘 동작한다.

워크시트 아무데서나 alt-f11을 누르면 vb편집기가 나오고 거기 붙여 넣기 한담에 F5를 눌러서
돌리면 끝.

소스를 조금만 보면 오름차순/내림차순 변경도 가능할지도..

--- 아래부터가 소스

Sub Sort_Active_Book()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
   iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
     & "Clicking No will sort in Descending Order", _
     vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
   For i = 1 To Sheets.Count
      For j = 1 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
         If iAnswer = vbYes Then
            If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
               Sheets(j).Move After:=Sheets(j + 1)
            End If
'
' If the answer is No, then sort in descending order.
'
         ElseIf iAnswer = vbNo Then
            If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
               Sheets(j).Move After:=Sheets(j + 1)
            End If
         End If
      Next j
   Next i
End Sub
2008. 6. 11. 10:10

지정한 폴더들의 이름 목록을 표시하는 엑셀 함수

지정한 드라이브의 하위포함 폴더 이름을 표시해 주는 엑셀 함수
폴더가 한단계씩 내려갈 수록 컬럼도 한칸씩 들어가도록 되어 있음
인터넷에서 찾은 VB소스를 엑셀에 맞게 조금 수정해서 사용하였음
엑셀 모듈에서 아래의 코드를 복사한 이후 직접 실행에서

FindFiles "C:\","A",1

같은 방법으로 실행하면 됨

'start_dir : 찾기 시작할 경로
' strStartCal : 기록을 시작할 컬럼명
' iStartRow : 기록을 시작할 ROW 번호
Function FindFiles(ByVal start_dir As String, ByVal strStartCal As String, ByVal iStartRow As Integer) As Integer
 Dim dirs() As String
 Dim dir_names() As String
 Dim num_dirs As Long
 Dim sub_dir As String
 Dim sub_name As String
 Dim file_name As String
 Dim i As Integer

 DoEvents
  
 sub_dir = Dir$(start_dir & "*", vbDirectory)
 Do While Len(sub_dir) > 0
     If UCase$(sub_dir) <> "PAGEFILE.SYS" And sub_dir <> "." And sub_dir <> ".." Then
  sub_name = sub_dir
  sub_dir = start_dir & sub_dir
  If GetAttr(sub_dir) And vbDirectory Then
      num_dirs = num_dirs + 1
      ReDim Preserve dirs(1 To num_dirs)
      ReDim Preserve dir_names(1 To num_dirs)
      dirs(num_dirs) = sub_dir & "\"
      dir_names(num_dirs) = sub_name
  End If
     End If

     sub_dir = Dir$(, vbDirectory)
 Loop

        '각각의 폴더에 대해 파일 찾기/재귀 호출
        For i = 1 To num_dirs
            Range(strStartCal + CStr(iStartRow)).FormulaR1C1 = dir_names(i)
            iStartRow = iStartRow + 1
            iStartRow = FindFiles(dirs(i), Chr(Asc(strStartCal) + 1), iStartRow)
            DoEvents
        Next i
 '결과 반환
 FindFiles = iStartRow
End Function