땡큐엑셀vba & 엑셀매크로

적용전

 

적용후

 

' http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=280817966
'
'가로로 한줄로 나열되어 있는 셀들이 엄청엄청 많이 있는데요 근데 이 셀들이 다 붙어 있어요!
'셀 4개씩 한묶음으로 하고 그 묶음 사이에 빈칸이 4칸이 오도록 하고 싶은데 어떻게 하면 좋을까요??
'일일이 하는 방법보단 자동으로 하는 방법이 있다면 알려주세요 셀이 너무 많아요 ㅠㅠ

'
' 빈칸을 몇개로 할지 A1셀에 값을 넣으시고(예:4)
' 한행에서 범위를 설정한후 실행하세요
'
' source by 땡큐엑셀vba & 엑셀매크로
'
Sub 빈칸삽입()
    Dim t As Range

    '빈칸수
    빈칸 = Range("A1")
    
    '선택한 범위
    Set Rng = Selection
    '선택한 범위의 갯수
    갯수 = Selection.Count
    
    몫 = Int(갯수 / 빈칸)
    
    '끝에서 부터 빈칸 삽입
    For i = 몫 To 1 Step -1
        Set t = Rng.Cells(1, i * 빈칸).Offset(0, 1).Resize(1, 빈칸)
        t.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Next i
    
    
    MsgBox "완료 되었습니다.", vbInformation, "땡큐엑셀vba & 엑셀매크로"
    
End Sub

 

셀과셀사이 빈칸삽입-Resize_Insert-응용예제-땡큐엑셀vba.xlsm
0.05MB

 

 

 

적용전

 

적용후

 

'
'source by 땡큐엑셀vba & 엑셀매크로
'
'3개의 셀삽입하고 _a, _b, _c 붙이기
Sub 열3개삽입()

    
    '선택된셀 오른쪽으로(xlToRight) 3개의 셀삽입(Insert)
    Selection.Offset(0, 1).Resize(1, 3).EntireColumn.Insert Shift:=xlToRight
    
    값 = Selection
    
    '첫번째
    Selection.Offset(0, 1) = 값 & "_a"
    '두번째
    Selection.Offset(0, 2) = 값 & "_b"
    '세번제
    Selection.Offset(0, 3) = 값 & "_c"


    MsgBox "완료되었습니다", vbInformation, "땡큐엑셀vba & 엑셀매크로"

End Sub

 

옆셀에 a_b_c붙이기-땡큐엑셀vba.xlsm
0.08MB

 

c:\temp 폴더

 

 

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=278999625&page=1#answer1
'
'안녕하세요. 현재 폴더안에 특정 파일수를 파악해서 알려주는 VBA를 사용중인데 속도가 너무 느려서요.
'꼭 사용자 정의 함수 형태로 만들어야 합니다.
'다른 형태로 알려 주는것들은 저도 이것 저것 가지고 있는데 사용자 정의 함수 형태로 만들어야 합니다.
'도스에서 CMD 에서 DIR로 파일수 떨궈서 알아 내는것하고 너무 속도 차이가 나서 사용하는데 문제가 많습니다.
'폴더당 10개 이런 수준이면 금방 하는데
'대상이 보통 폴더당 1,000개~2,000개의 jpg 파일이 있고 100개 정도의 폴더를 검색합니다. (네트워크 드라이버로  NAS 스토리지 접속)
'고수님들의 답변 부탁 드립니다. (파일 첨부 합니다.)




'source by 땡큐엑셀vba & 엑셀매크로
'
'해당경로의 jpg파일갯수를 출력합니다.
Function TQjpg(strPath)
   Dim cmd As String
   Dim res
  
   '윈도우를 구동하는 쉘 프로그램(cmd 명령창)
   Dim goWSH: Set goWSH = CreateObject("WScript.Shell")
  
   ' cmd창에서 dir 경로\*.* | find "jpg" /c 한것과 같습니다. /c 옵션을 사용하면 숫자가 나옵니다.
   cmd = "cmd.exe /c dir " & strPath & "\*.* | find ""jpg"" /c "
   
   Dim aRet: Set aRet = goWSH.exec(cmd)
   res = CLng(aRet.stdout.readall())
  
   TQjpg = res
  
End Function



'
'source by 땡큐엑셀vba & 엑셀매크로
'
'해당경로의 jpg파일리스트를 출력합니다.
'
Function TQList(strPath)
   Dim cmd As String
   Dim res
  
  
   '윈도우를 구동하는 쉘 프로그램(cmd 명령창)
   Dim goWSH: Set goWSH = CreateObject("WScript.Shell")
  
   'dir /w 는 파일명만 출력합니다.
   cmd = "cmd.exe /c dir /w " & strPath & "\*.* | find ""jpg"" "
   
   Dim aRet: Set aRet = goWSH.exec(cmd)
   res = aRet.stdout.readall()
  
   TQList = res
  
End Function

 

 

cmd_dir을이용한파일갯수및파일리스트_땡큐엑셀vba.xlsm
0.02MB

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=283220237

'날짜가
'2017.05.06 ~ 2018.08.06
'2016.5.08 ~2017.08.2
'이렇게 날짜가 입력되어 있을때
'1. 날짜를 yyyy.mm.dd로 바꾸는방법 그러니까 5.08을 05.08로 표시되도록
'2. 물결 양 옆 공백 제거하는법
'부탁드립니다.

'module
'Source by 땡큐엑셀vba & 엑셀매크로
'
'공백제거
Function removeSpace(r1 As String) As String

    
    변환후 = Replace(r1, " ", "")
    
    removeSpace = 변환후
    
End Function


'Source by 땡큐엑셀vba & 엑셀매크로
'yyyymmdd형식으로 변환
Function yyyymmdd(r1 As String) As String

    '물결(~)을 구분자로 나눈다
    분리보관 = Split(r1, "~")
    
    '물결을 기준으로 앞부분 날짜
    앞부분 = Split(분리보관(0), ".")
    
    '물경을 기준으로 뒷부분 날짜
    뒷부분 = Split(분리보관(1), ".")
    

    '앞부분 날짜에서 월과 일자가 두자리씩 구성되었는지 확인하여 아닐경우 앞에 0을 붙인다.
    If Len(앞부분(1)) = 1 Then 앞부분(1) = "0" & 앞부분(1)
    If Len(앞부분(2)) = 1 Then 앞부분(2) = "0" & 앞부분(2)
    
    '뒷부분 날짜에서 월과 일자가 두자리씩 구성되었는지 확인하여 아닐경우 앞에 0을 붙인다.
    If Len(뒷부분(1)) = 1 Then 뒷부분(1) = "0" & 뒷부분(1)
    If Len(뒷부분(2)) = 1 Then 뒷부분(2) = "0" & 뒷부분(2)

    
    '앞부분(0),뒷부분(0)에는 년도가 들어있음
    변경후 = 앞부분(0) & "." & 앞부분(1) & "." & 앞부분(2) & "~" & 뒷부분(0) & "." & 뒷부분(1) & "." & 뒷부분(2)
    
    
    yyyymmdd = 변경후

End Function



 

공백제거및_yyyymmdd포맷으로변환-replace_split-사용자정의함수-땡큐엑셀vba.xlsm
0.16MB

 

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=280221604
'
'다음 표에서 최대값만큼 가지고 있는 이름을 모두 추출해서 한 칸에 넣으려고 합니다.
'그러니까 한 칸에 최댓값인 3을 가지고 있는 나,라,바 가 적히도록 하는 방법을 찾고있습니다.



'최대값에 해당하는 이름을 출력하는 사용자정의함수
'이름이 1행에 있다는 가정에서 실행하세요.
'사용방법 : =MaxName(범위)
'예[I2]셀 =MaxName(B2:H2)
'
'
'
'source by 땡큐엑셀vba & 엑셀매크로
'
Function MaxName(rng As Range) As String

    '해당범위에서 최대값을 구한다
    최대값 = Application.WorksheetFunction.Max(rng)
    
    '해당범위를 돌면서 최대값과 일치하는 셀이 있다면 이름을 계속 추가한다.
    For Each r In rng
        
        If r = 최대값 Then
            최대값이름 = 최대값이름 & " " & Cells(1, r.Column)
        End If
    
    Next

    MaxName = 최대값이름

End Function

 

 

최대값에해당하는이름구하기-WorksheetFunction.Max-땡큐엑셀vba.xlsm
0.05MB

 

넘버에 있는 파일명 찾아 사진넣기(jpg)

 

 

'https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=302833695


'이번에 엑셀 정리하면서
'사진만 수만장을 넣어야 하는데요..
'ex)
'셀 이름: ABC -456
'폴더 내 사진 파일 이름 : ABC-456
'이런식이면
'사진 크기가 셀에 맞게 자동으로 파일명을 찾아서 한번에
'수만장 삽입 되게 할 수 없을까요?
'하나씩 넣으니 너무 오래걸려서요~


'
'Source by 땡큐엑셀vba & 엑셀매크로
'
Sub 땡큐엑셀main()

    Dim StrFile As String
    
    Application.ScreenUpdating = False
    On Error Resume Next '도중 에러 무시
    
    
    For Each ea In Range("A:A")
    
        If ea.Value = "" Then
            Exit For
        Else
        
            '사진파일이 있는 경로를 아래와 같이 주면 됩니다.
            'StrFile = "절대경로" & Target.Value & ".jpg"
            StrFile = "c:\temp\" & ea.Value & ".jpg"
            If Dir(StrFile) <> "" Then '파일유무 체크
        
                ActiveSheet.Pictures.Insert(StrFile).Select '사진넣기
                With Selection
                    .ShapeRange.LockAspectRatio = msoFalse '비율유지 해지
                    .Top = ea.Offset(0, 1).Top      '셀크기에 맞도록 사진 사이즈 조정
                    .Left = ea.Offset(0, 1).Left      '셀크기에 맞도록 사진 사이즈 조정
                    .Width = ea.Offset(0, 1).Width      '셀크기에 맞도록 사진 사이즈 조정
                    .Height = ea.Offset(0, 1).Height      '셀크기에 맞도록 사진 사이즈 조정

                End With
            
            End If
            
        End If
    
    Next

    Application.ScreenUpdating = True
    
    
    MsgBox "완료되었습니다", vbInformation, "땡큐엑셀vba & 엑셀매크로"
    
End Sub


 

대량이미지넣기-pictures_insert-땡큐엑셀vba.xlsm
0.14MB

 

 

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=279914404
'
'표와 같이 3개의 구간 3번을 거쳐서 결과값을 찾는 작업인데요
'index/match로 하면 1개 구간은 검색이 되는데 3번 전부 매칭시켜서 답을 찾는게 안되네요 ㅠㅠ
'뭘 어떻게 해야 할까요??ㅠㅠ
'=INDEX(B2:E28,MATCH(B30&C30&D30,B2:B28&C2:C28&D2:D28,-1),4)
'이렇게 해도 안되더라구요
'저 구간들을 그냥 30, 19, 14로만 표기해서도 해봤는데 안되는데
'어떻게 해야 할까요??



'
'source by 땡큐엑셀vba & 엑셀매크로
'
Sub 값찾기()

    조건1 = Cells(1, "B")
    조건2 = Cells(1, "C")
    조건3 = Cells(1, "D")
    
    마지막행 = Cells(Rows.Count, "B").End(xlUp).Row
    
    구분자 = "~"
    '마지막행까지 루프돌며 3개의 구간을 만족하는 값 찾기
    For i = 2 To 마지막행
    
        '조건1
        'split내장함수를 사용하여 두개의 값으로 나눈다. 두개의 값은 값1(0),갑1(1)에 들어간다.
        값1 = Split(Cells(i, "B"), 구분자)
        If 조건1 >= Int(값1(0)) And 조건1 <= Int(값1(1)) Then
        
            
            '조건2
            값2 = Split(Cells(i, "C"), 구분자)
            If 조건2 >= Int(값2(0)) And 조건2 <= Int(값2(1)) Then
            
            
                '조건3
                값3 = Split(Cells(i, "D"), 구분자)
                If 조건3 >= Int(값3(0)) And 조건3 <= Int(값3(1)) Then
            
                    '최종 일치하는 행 찾았다.
                    Cells(1, "E") = Cells(i, "E")
                
                End If '조건3

            
            End If '조건2

        
        End If '조건1
 
    Next i


    MsgBox "완료되었습니다", vbInformation, "땡큐엑셀vba & 엑셀매크로"

End Sub

 

 

3개의구간을만족하는값찾기-spilt_int-땡큐엑셀vba.xlsm
0.17MB

 

초기화

 

 

sheet2!a1셀에 값입력

 

 

Sheet1!b1셀에 카운트 증가

 

 

 

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=284157540

'sheet1에 a1 이라는 셀에는
'sheet2의 a1 값이 참조되어 있습니다
'sheet2에 a1 값이 오면 sheet1의 a1에 같은 값이 뜨면서 sheet1의 b1에는 숫자 1이 카운트 되고
'그 후 sheet2의 a1에 값이 지워지면 sheet1의 a1에도 값이 지워지겠지만 b1에는 1이 입력되어 있다가
'sheet2의 a1에 새롭게 숫자가 입력되면 sheet1의 b1에는 숫자2로 카운트 되는
'카운트가 누적되는 함수를 만들려면 어떻게 해야 할까요


'
' Source by 땡큐엑셀vba & 엑셀매크로
'
' calculate이벤트는 워크 시트를 다시 계산 한 후에 발생합니다.이때 특정된 셀을 분석하면 됩니다.
Private Sub Worksheet_Calculate()

    'A1셀이 0,널이 아닌경우 B1셀에 1씩 증가
    If Range("A1") = 0 Or Range("A1") = "" Then
    
    Else
        Range("B1") = Range("B1") + 1
    End If
    
End Sub

 

 

카운트증가-Worksheet_Calculate-땡큐엑셀vba.xlsm
0.14MB

 

땡큐엑셀vba

 

회원 시트

 

출력 시트

 

수식적용
수식적용

 

 

 

결과 - pdf파일

 

 

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=279378268&page=1#answer1

'엑셀매크로 입니다.
'"회원" 워크시트에 있는 회원코드별로 매칭되는 데이터를 끌어와서
'반복인쇄하는것은 성공하였습니다.!!!
'여기서 Range("b7:g13").Select 반복인쇄 대신,
'전체 PDF 파일로 변환하는 매크로를 원합니다. (샘플첨부파일)
'(회원 지역별로 서울, 부산, 대구 등등 으로 분할 저장할수 있으면 더욱 좋습니다.)
'엑신님들의 답변 부탁드립니다. ^^/




'사전에 출력될 범위를 인쇄영역으로 설정하세요.

'
'source by 땡큐엑셀vba & 엑셀매크로
'
Sub 회원전체pdf로저장()

    Set sht = ActiveSheet
    Set shta = Sheets("회원")
    
    '경고창 무시하기
    Application.DisplayAlerts = False
    
    '루프
    For i = 3 To 16
        '출력시트 A3셀에 회원코드를 넣어주면 나머지에는 수식이 걸려있어서 자동으로 변경됨
        sht.Range("A3") = shta.Range("A" & i)
        
        Call saveAsPdf(Range("A3"))
        'Selection.PrintOut Copies:=1, Collate:=True
    Next i

    '경고창 활성화
    Application.DisplayAlerts = True
    
    
    
    MsgBox "완료되었습니다", vbInformation, "땡큐엑셀vba & 엑셀매크로"
    
End Sub



Sub saveAsPdf(strOpt1 As String)

    '경로는 변경하여 사용하세요
    경로 = "C:\temp\"
    '회원코드가 파일명이 됩니다.
    파일명 = strOpt1
    '그리고 확장자 pdf를 붙인다.
    전체경로 = 경로 & 파일명 & ".pdf"
    
    'pdf로 변환하여 해당경로에 저장한다.
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=전체경로, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False
        

End Sub

 

회원전체 pdf파일로저장-ExportAsFixedFormat-땡큐엑셀vba.xlsm
0.02MB

 

실행전

 

실행후

 

 

' http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=287032869
'
' 토끼 셀마다 빨간색 "산"을 추가해야하는 비슷한 노가다를 하고 있는데.. 어떻게 하면 빠르게 할 수 있을까요? ㅠㅠ


'
' Source by 땡큐엑셀vba & 엑셀매크로
'
Sub 컬러문자추가()

    Set 검색범위 = Selection
    찾을값 = Cells(1, "D")
    추가문구 = Cells(1, "E")
    변경값 = 추가문구 & 찾을값
        
      
    '범위 루프
    For Each R In 검색범위
    
        '글자 위치
        pos = InStr(1, R.Value, 찾을값)
        '길이
        iLen = Len(R.Value)
        
        '찾을값이 포함되어 있다면 변경값으로 교체함
        If pos > 0 Then
            temp = Replace(R.Value, 찾을값, 변경값) 'repalce함수를 사용
            R.Value = temp
            
            '글자 위치(예:산토끼)
            pos = InStr(1, R.Value, 변경값)
            
            '글자색 변경
            With R.Characters(Start:=pos, Length:=1).Font
                '.Name = "맑은 고딕"
                '.FontStyle = "보통"
                '.Size = 11
                '.Strikethrough = False
                '.Superscript = False
                '.Subscript = False
                '.OutlineFont = False
                '.Shadow = False
                '.Underline = xlUnderlineStyleNone
                .Color = -16776961
                '.TintAndShade = 0
                '.ThemeFont = xlThemeFontMinor
            End With
            
        End If
        
        
    Next
    
    MsgBox "완료되었습니다.", vbInformation, "땡큐엑셀vba & 엑셀매크로"

End Sub

 

 

문구찾은후 컬러문자추가-for each_characters.font-땡큐엑셀vba.xlsm
0.02MB

 

땡큐엑셀vba