¢ªOffice´ØÏ¢¥á¥â

¢ªExcel´ØÏ¢

¢ªC¡ô¤Ë¤è¤ëExcelÀ©¸æ

¢ªVisual Basic(.NET°ÊÁ°)

°ìÈÌ

  • VarType¤Ç8204¤Ê¤É¤¬Ê֤äƤ¯¤ë¤È¤­
  • ExcelRelaxTools Addin 2014.1.29
    • 5ǯ´Ö(2009ǯ¡Á)¤Ë¤ï¤¿¤Ã¤ÆºîÀ®¤·¤¿¥Þ¥¯¥í¤òÈÆÍÑŪ¡¢ÂηÏŪ¤Ë¤Þ¤È¤á¤¿¤â¤Î¤Ç¤¹¡£

Tips

źÉÕ¥Õ¥¡¥¤¥ë¤ò¤Ä¤±¤Æ¥á¡¼¥ë

²èÌ̤ò¥­¥ã¥×¥Á¥ã¤¹¤ë

Google¥Þ¥Ã¥×ɽ¼¨

CSV¤äExcel¤ËSQL¤ò¼Â¹Ô

¥Þ¥¯¥í¤Î¼«Æ°¼Â¹Ô¤òÍÞÀ©

·Ù¹ðÍÞÀ©

Application.DisplayAlerts = False '·Ù¹ðÍÞÀ©

¥Õ¥¡¥¤¥ë¥À¥¤¥¢¥í¥°¡Ê¥ª¡¼¥×¥ó¡Ë

   Dim dlg As FileDialog
   Set dlg = Application.FileDialog(msoFileDialogOpen)
   dlg.InitialFileName = "C:\Windows\"
   dlg.Show 'execute ¤À¤È³«¤¯½ê¤Þ¤Ç¤ä¤Ã¤Æ¤¯¤ì¤ë
   
   Cells(1, 1) = dlg.SelectedItems(1)
  • Win32API¤òľá¤­¤·¤¿¤¤¾ì¹ç
    • https://www.moug.net/tech/acvba/0020007.html
      Public Declare Function GetOpenFileName _
                             Lib "comdlg32.dll" _
                               Alias "GetOpenFileNameA" ( _
                               pOpenFileName As OPENFILENAME) As Long
      
      'pOpenFileName¹½Â¤ÂÎ(¥æ¡¼¥¶¡¼ÄêµÁ·¿)¤ÎÀë¸À
      Type OPENFILENAME
          lStructSize       As Long    '¹½Â¤ÂΤΥµ¥¤¥º
          hwndOwner         As Long    '¥À¥¤¥¢¥í¥°¤ò½êÍ­
                                       '  ¤¹¤ë¥¦¥¤¥ó¥É¥¦¥Ï¥ó¥É¥ë
          hInstance         As Long    '¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¥¤¥ó¥¹¥¿¥ó¥¹
          lpstrFilter       As String  '¥Õ¥£¥ë¥¿
          lpstrCustomFilter As Long    '¥æ¡¼¥¶ÄêµÁ¥Õ¥£¥ë¥¿
          nMaxCustrFilter   As Long    '¥æ¡¼¥¶ÄêµÁ¥Õ¥£¥ë¥¿¤Î
                                       '  ¥Ð¥Ã¥Õ¥¡¥µ¥¤¥º
          nFilterIndex      As Long    '¥Ç¥Õ¥©¥ë¥È¥Õ¥£¥ë¥¿¤Î¥¤¥ó¥Ç¥Ã¥¯¥¹
          lpstrFile         As String  'ÁªÂò¤µ¤ì¤¿¥Õ¥¡¥¤¥ë̾
          nMaxFile          As Long    '¥Õ¥¡¥¤¥ë̾¤Î¥Ð¥Ã¥Õ¥¡
          lpstrFileTitle    As String  'ÁªÂò¤µ¤ì¤¿¥Õ¥¡¥¤¥ë̾¤Î¥¿¥¤¥È¥ë
          nMaxFileTitle     As Long    '¥Õ¥¡¥¤¥ë̾¤Î¥¿¥¤¥È¥ë¤Î¥Ð¥Ã¥Õ¥¡
          lpstrInitialDir   As String  '½é´ü¥Ç¥£¥ì¥¯¥È¥ê
          lpstrTitle        As String  '¥À¥¤¥¢¥í¥°¥Ü¥Ã¥¯¥¹¤Î¥¿¥¤¥È¥ë
          Flags             As Long    '¥ª¥×¥·¥ç¥ó
          nFileOffset       As Integer '¥Õ¥¡¥¤¥ë̾¤ÎºÇ¸å¤Î¡Ö\¡×¤Þ¤Ç¤Î
                                       '  ¥ª¥Õ¥»¥Ã¥ÈÃÍ
          nFileExtension    As Integer '³ÈÄ¥»Ò¤Þ¤Ç¤Î¥ª¥Õ¥»¥Ã¥ÈÃÍ
          lpstrDefExt       As String  '¥Ç¥Õ¥©¥ë¥È¤Î³ÈÄ¥»Ò
          lCustrData        As Long    'OS¤¬¥Õ¥Ã¥¯´Ø¿ô¤ËÅϤ¹¥¢¥×¥êÄêµÁ¤Î¥Ç¡¼¥¿
          lpfnHook          As Long    '¥á¥Ã¥»¡¼¥¸¤ò½èÍý¤¹¤ë¥Õ¥Ã¥¯´Ø¿ô
                                       '  ¤Ø¤Î¥Ý¥¤¥ó¥¿
          lpTemplateName    As Long
      End Type
      
      'Äê¿ôÀë¸À
      'Ê£¿ô¤Î¥Õ¥¡¥¤¥ë¤òÁªÂò²Äǽ¤Ë
      Public Const OFN_ALLOWMULTISELECT = &H200
      '¥Õ¥¡¥¤¥ë¤¬Â¸ºß¤·¤Ê¤«¤Ã¤¿¾ì¹ç¡¢¿·µ¬ºîÀ®¤¹¤ë¤«¤É¤¦¤«É½¼¨
      Public Const OFN_CREATEPROMPT = &H2000
      '¥¨¥¯¥¹¥×¥í¡¼¥é·Á¼°¤Î¥À¥¤¥¢¥í¥°¤ò»ÈÍÑ
      Public Const OFN_EXPLORER = &H80000
      '¸ºß¤·¤Ê¤¤¥Õ¥¡¥¤¥ë̾¤òÆþÎÏÉԲĤË
      Public Const OFN_FILEMUSTEXIST = &H1000
      '¡ÖÆÉ¤ß¼è¤êÀìÍѡץÁ¥§¥Ã¥¯¥Ü¥Ã¥¯¥¹¤òÈóɽ¼¨
      Public Const OFN_HIDEREADONLY = &H4
      '¥«¥ì¥ó¥È¥Ç¥£¥ì¥¯¥È¥ê¤ò¥À¥¤¥¢¥í¥°¤Î¥«¥ì¥ó¥È¥Ç¥£¥ì¥¯¥È¥ê¤Ë¤¹¤ë
      Public Const OFN_NOCHANGEDIR = &H8
      Public Const OFN_NODEREFERENCELINKS = &H100000
      '¥Í¥Ã¥È¥ï¡¼¥¯¥³¥ó¥Ô¥å¡¼¥¿¤òÈóɽ¼¨¤Ë
      Public Const OFN_NONETWORKBUTTON = &H20000
      Public Const OFN_NOREADONLYRETURN = &H8000
      Public Const OFN_NOVALIDATE = &H100
      '¥Õ¥¡¥¤¥ë¤¬Â¸ºß¤·¤Æ¤¤¤¿¾ì¹ç¡¢¾å½ñ¤­¤òÌ䤤¹ç¤ï¤»¤ë
      Public Const OFN_OVERWRITEPROMPT = &H2
      'Í­¸ú¤Ê¥Ñ¥¹Ì¾¤Î¤ß¤òÆþÎϲÄǽ¤Ë
      Public Const OFN_PATHMUSTEXIST = &H800
      '¡ÖÆÉ¤ß¼è¤êÀìÍѡץÁ¥§¥Ã¥¯¥Ü¥Ã¥¯¥¹¤ò¥ª¥ó¤Ë¤¹¤ë
      Public Const OFN_READONLY = &H1
      '¡Ö¥Ø¥ë¥×¡×¥Ü¥¿¥ó¤Îɽ¼¨
      Public Const OFN_SHOWHELP = &H10
      '³ÈÄ¥»Ò¤¬¥Ç¥Õ¥©¥ë¥È¤Î³ÈÄ¥»Ò¤È°Û¤Ê¤ë¾ì¹ç¤ËÀßÄꤵ¤ì¤ë¥Õ¥é¥°
      Public Const OFN_EXTENSIONDIFFERENT = &H400
      
      Public Function GetFileName() As String
          Dim pOpenFileName As OPENFILENAME
          Dim lngRet As Long
      
          'Access¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤Î¥Ï¥ó¥É¥ë¤ò¼èÆÀ
          pOpenFileName.hwndOwner = Application.hWndAccessApp
          pOpenFileName.hInstance = 0
          '¥Õ¥¡¥¤¥ë¥Õ¥£¥ë¥¿¤ÎÀßÄê
          pOpenFileName.lpstrFilter = "Á´¤Æ¤Î¥Õ¥¡¥¤¥ë (*.*)" & _
                                      String(1, vbNullChar) & _
                                      "*.*" & _
                                      String(2, vbNullChar)
          pOpenFileName.lpstrCustomFilter = 0
          pOpenFileName.nMaxCustrFilter = 0
          pOpenFileName.nFilterIndex = 1
          pOpenFileName.lpstrFile = String(511, vbNullChar)
          pOpenFileName.nMaxFile = 511
          pOpenFileName.lpstrFileTitle = String(512, vbNullChar)
          pOpenFileName.nMaxFileTitle = 511
          pOpenFileName.lpstrInitialDir = String(1, vbNullChar)
          pOpenFileName.lpstrTitle = String(1, vbNullChar)
          pOpenFileName.nFileOffset = 0
          pOpenFileName.nFileExtension = 0
          pOpenFileName.lpstrDefExt = String(1, vbNullChar)
          pOpenFileName.lCustrData = 0
          pOpenFileName.lpfnHook = 0
          pOpenFileName.lpTemplateName = 0
          pOpenFileName.lStructSize = Len(pOpenFileName)
          'ÆÉ¼èÀìÍÑ¥Õ¥¡¥¤¥ë¤ò±£¤¹
          pOpenFileName.Flags = OFN_HIDEREADONLY _
                                Or OFN_EXPLORER
      
          lngRet = GetOpenFileName(pOpenFileName)
      
          GetFileName = Left(pOpenFileName.lpstrFile, _
                             InStr(pOpenFileName.lpstrFile, vbNullChar) - 1)
      
      End Function

¥¹¥¯¥ì¥¤¥Ô¥ó¥°

¥¢¥É¥¤¥ó´ØÏ¢

Excel¤ËGoogle Maps API¤ÇÃϿޤòËä¤á¹þ¤ß¡¢½»½ê¸¡º÷¡¢³ÈÂç¡¿½Ì¾®¡¢ÃϿ޼ïÎàÊѹ¹

³«¤¤¤Æ¤¤¤ë¥Õ¥¡¥¤¥ë¤ÎÃæ¤«¤é̾Á°¤Îº¸Â¦¤¬°ú¿ô¤È¹çÃפ¹¤ë¥Õ¥¡¥¤¥ë¤òõ¤¹

'£²¤Ä°Ê¾å¤¢¤Ã¤¿¤é¥¨¥é¡¼
Function schFile(name As String) As Workbook

    Dim cnt As Integer
    cnt = 0

    Set schFile = Nothing

    Dim bk As Workbook
    For Each bk In Workbooks
        Dim ln As Integer
        ln = Len(name)
        Debug.Assert (ln > 0)
        If StrConv(Left(bk.name, ln), vbUpperCase) = StrConv(name, vbUpperCase) Then
            If Not (schFile Is Nothing) Then
                MsgBox ("[" & name & "]¤Ç»Ï¤Þ¤ë¥Õ¥¡¥¤¥ë¤¬£²¤Ä°Ê¾å¤¢¤ê¤Þ¤¹")
                End
            End If

            Debug.Assert (schFile Is Nothing)  'Ʊ¤¸Ì¾Á°¤Ç»Ï¤Þ¤ë¥Õ¥¡¥¤¥ë¤¬£²¤Ä°Ê¾å¤¢¤Ã¤¿¤é¥¨¥é¡¼¤Ë¤Ê¤ê¤Þ¤¹
            Set schFile = bk
            '¤³¤³¤Ç¤¹¤°¤ÏÊÖ¤é¤Ê¤¤¡¡£²¤Ä°Ê¾å¤¢¤Ã¤¿¤é¤Þ¤º¤¤¤«¤é
        End If
    Next

    If schFile Is Nothing Then
        MsgBox ("[" & name & "]¤Ç»Ï¤Þ¤ë¥Õ¥¡¥¤¥ë¤¬¸«¤Ä¤«¤ê¤Þ¤»¤ó")
        End
    End If

End Function

countifs¤Î¿ô¼°¤ò¸µ¤Ë¡¢Æ±¤¸¾ò·ï¤Ç¥Õ¥£¥ë¥¿¤ò¤«¤±¤ë

Sub ¿ô¼°¤«¤é¥Õ¥£¥ë¥¿¡¼(r As Range)
Dim strSuusiki As String
Dim varPrm As Variant
Dim sh As Worksheet
Dim ac As Worksheet
Dim lngLoop As Long
Dim lngColNo As Long
Dim strJoken As String
Dim rngFil As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set sh = Sheets("hoge")
    Set ac = r.Worksheet

    strSuusiki = r.Formula ''³ºÅö¥»¥ë¤Î¿ô¼°¤ò¼è¤ê½Ð¤¹
    strSuusiki = Replace(strSuusiki, "=countifs(", "", , , vbTextCompare) '¡Ç;ʬ¤Ê¤È¤³¤í¤ò¾Ã¤¹
    strSuusiki = Replace(strSuusiki, "=countif(", "", , , vbTextCompare) '¡Ç;ʬ¤Ê¤È¤³¤í¤ò¾Ã¤¹
    strSuusiki = Replace(strSuusiki, ")", "") '¡Ç;ʬ¤Ê¤È¤³¤í¤ò¾Ã¤¹
    varPrm = Split(strSuusiki, ",") '¡ÇCountifs¤Î¥Ñ¥é¥á¡¼¥¿¤Î¤ß¤òÇÛÎó¤Ëʬ³ä¤¹¤ë

    If Not sh.AutoFilterMode Then ''¥ª¡¼¥È¥Õ¥£¥ë¥¿¡¼¤¬ÉÕ¤¤¤Æ¤Ê¤¤¾ì¹ç
        Intersect(sh.UsedRange, sh.Range("10:65535")).AutoFilter '¡Ç¥Õ¥£¥ë¥¿¡¼¤ò¤Ä¤±¤ë
    End If

    If sh.FilterMode Then '¡Ç¥Õ¥£¥ë¥¿¡¼¤¬¤«¤«¤Ã¤Æ¤¤¤ë¾õÂ֤ΤȤ­¤Ï¥Õ¥£¥ë¥¿¡¼¥¯¥ê¥¢
        sh.ShowAllData
    End If

    Set rngFil = sh.AutoFilter.Range

    For lngLoop = 0 To UBound(varPrm) Step 2
        lngColNo = Range(varPrm(lngLoop)).Column    ''ÇÛÎó¤Î¶ö¿ôÈÖÌܡḡº÷¾ò·ïÈϰϤΥ«¥é¥àÈÖ¹æ¤ò¼èÆÀ
        strJoken = varPrm(lngLoop + 1)              ''ÇÛÎó¤Î´ñ¿ôÈÖÌܡḡº÷¾ò·ï¤ò¼èÆÀ
        If InStr(strJoken, """") > 0 Then
            strJoken = Replace(strJoken, """", "") '¡Ç""¤¬¤¢¤ë¾ì¹ç¤ÏÄê¿ô¡Ê¡É¡É¤Ï¾Ã¤¹¡Ë
        Else
            strJoken = ac.Range(strJoken).Value '¡Ç¡É¡É¤¬¤Ê¤¤¾ì¹ç¤Ï¥»¥ë¤Ø¤Î»²¾È¤Î¤¿¤á»²¾ÈÀè¤ÎÃͤò¼èÆÀ
        End If


        rngFil.AutoFilter Field:=lngColNo, Criteria1:=strJoken
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

¥Ï¥¤¥Ñ¡¼¥ê¥ó¥¯¤ò¥¯¥ê¥Ã¥¯¤·¤¿¤é¾å¤Î¹Ô¡Ê£³¹ÔÌܡˤˤ¢¤²¤ë

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
   Dim r As Integer
   r = Target.Range.row
   If r = 3 Then
       Exit Sub
   Else
       ThisWorkbook.Worksheets(1).Activate
       Rows("3:3").Select
       Selection.EntireRow.Insert

       r = r + 1
       Rows(r & ":" & r).Select
       Selection.Cut
       Range("A3").Select
       ActiveSheet.Paste

       Range("A" & r).Select
       Selection.EntireRow.Delete
   End If
End Sub

¥»¥ë¤ÎÃͤòʸ»úÎó¤È¤·¤Æ¼èÆÀ¤·¤¿¤¤¾ì¹ç

Cells(i,j).Text

¥Õ¥£¥ë¥¿·Ï

  • ¥Õ¥£¥ë¥¿¤ò¥¯¥ê¥¢¤¹¤ë
    ActiveSheet.ShowAllData

¸½ºß¸«¤Æ¤¤¤ë¥Ö¥Ã¥¯¤ÎÁ´¥·¡¼¥È¤«¤é_YMDHMS¤È¤¤¤¦ÃÍ¤ÎÆþ¤Ã¤¿¥»¥ë¤ò¤¹¤Ù¤ÆÃµ¤·¡¢¤½¤Î²¼¤Ë¤¢¤ë¥»¥ë¤Ë¥Õ¥©¡¼¥Þ¥Ã¥È¤òÀßÄꤹ¤ë

 Sub ÆüÉդΥե©¡¼¥Þ¥Ã¥È½¤Àµ()
   Debug.Print ("¥Õ¥©¡¼¥Þ¥Ã¥È½¤Àµ³«»Ï")
   Dim bk As Workbook
   Dim sht As Worksheet
   Set bk = ActiveWorkbook
   Dim i As Integer
   For i = 1 To bk.Worksheets.Count
       Set sht = bk.Worksheets(i)
       With sht
           .Activate
           .Cells(1, 1).Select
           Dim r As Range
           Set r = Cells.Find(What:="_YMDHMS", After:=ActiveCell, LookIn:=xlValues, _
               LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
               MatchCase:=False, MatchByte:=False, SearchFormat:=False)
           If Not r Is Nothing Then
               Dim firstPos As String
               firstPos = r.Address
               Do
                   Dim s As String
                   .Cells(r.row, r.Column).Select
                   If Trim(.Cells(r.row + 1, r.Column)) <> "" Then
                       s = .Cells(r.row, r.Column)
                       Debug.Print (.Name & ":" & r.row & "," & r.Column & "," & s)
                       .Cells(r.row + 1, r.Column).NumberFormatLocal = "yyyy-mm-dd hh:mm:ss"
                       .Cells(r.row + 1, r.Column).HorizontalAlignment = xlLeft
                       Dim rcol As Range
                       Set rcol = .Columns(r.Column)
                       rcol.AutoFit
                   End If
                   Set r = Cells.FindNext(r)
                   DoEvents
               Loop While (r.Address <> firstPos)
           Else
               '¤½¤â¤½¤â¤Ê¤¤
           End If
       End With
   Next
   MsgBox ("OK")
 End Sub

º£ÁªÂò¤·¤Æ¤¤¤ë¥·¡¼¥È

  • Application.SelectedSheets ¤ò»²¾È¤¹¤ë

¡Ö̾Á°¡×¤ÎÁ´¾Ã¤·

  • ¥á¥Ë¥å¡¼¤«¤é¾Ã¤·¤Æ¤¤¤ë¤È°ì²ó¤Ë£±¤Ä¤·¤«¾Ã¤»¤Ê¤¯¤ÆÌÌÅݤʤΤǡ¢°Ê²¼¤Î¥Þ¥¯¥í¤Ç
    for i = ActiveWorkbook.Names.Count to 1 step -1
      ActiveWorkbook.Names(i).Delete
    Next

¥Ñ¥¹¥ï¡¼¥ÉÉÕ¤­¤Ç¥Ö¥Ã¥¯¤òÊݸ¤¹¤ë

ActiveWorkbook.SaveAs Filename:= _
"hoge.xls", FileFormat:= _
xlExcel8, Password:="anestec", WriteResPassword:="", ReadOnlyRecommended _
:=False, CreateBackup:=False

¼ê¤Ã¼è¤êÁ᤯Excel¥·¡¼¥È¤Î°ìÍ÷¤òÆÀ¤ë¤Ë¤Ï

  • ALT+F11¤ò²¡²¼(VBA¥¨¥Ç¥£¥¿¤¬µ¯Æ°)
  • CTRL+G¤ò²¡²¼(¥¤¥ß¥Ç¥£¥¨¥¤¥È¥¦¥¤¥ó¥É¥¦¤¬µ¯Æ°)
    For Each i In ThisWorkbook.Sheets: debug.print i.name : next i 
    ¤ò¥¿¥¤¥×¤·¤ÆEnter¤ò²¡²¼

¡ÎEsc¡Ï¥­¡¼¤Ë¤è¤ëExcel VBA¤Î¼Â¹ÔÃæÃǤòËɻߤ¹¤ë

¸ß´¹À­¥Á¥§¥Ã¥¯¤Î¥À¥¤¥¢¥í¥°¤¬½Ð¤ë¤Î¤òÍÞÀ©

  • Office2007¤Ç .xls¥Õ¥¡¥¤¥ë¤òÊݸ¤·¤è¤¦¤È¤·¤¿¤È¤­¤Ë½Ð¤ë¥À¥¤¥¢¥í¥°¤òÍÞÀ©¤·¤¿¤¤¾ì¹ç¤Ï¡¢¾å½ñ¤­³Îǧ¤ÎÍÞÀ©¤ÈƱ¤¸¤è¤¦¤Ë
    Application.DisplayAlerts=False
    ¤È¤¹¤ë

Excel¤ÇÆÃÄê¤ÎÃͤˤʤ俤Ȥ­¤Î¥¢¥¯¥·¥ç¥ó

  • ÆÃÄê¤Î¥»¥ë¤ËÆÃÄê¤ÎÃͤ¬ÆþÎϤµ¤ì¤¿¤È¤­¤Ë¥Þ¥¯¥í¤ò¼«Æ°Åª¤Ë¼Â¹Ô¤¹¤ë¤Ë¤Ï¡©
    • http://www.asahi-net.or.jp/~zn3y-ngi/YNxv9c7.html
    • WorkSheet_Change¤Î¥¤¥Ù¥ó¥È¥×¥í¥·¡¼¥¸¥ã¤Ë½èÍý¤ò½ñ¤±¤ÐÎɤ¤¡£ÅöÁ³¤Ê¤¬¤éExcel¤ÎÀßÄê¤Ç¥Þ¥¯¥í¼Â¹Ô¤òµö²Ä¤·¤Æ¤ª¤¯É¬ÍפϤ¢¤ë¡Ê¥ª¥×¥·¥ç¥ó¤Î¥»¥­¥å¥ê¥Æ¥£ÀßÄê¡Ë

¥Ä¥ê¡¼¥Ó¥å¡¼¥³¥ó¥È¥í¡¼¥ë

VBA ¥³¥ó¥Ñ¥¤¥ë¥¨¥é¡¼¤È¼Â¹Ô»þ¥¨¥é¡¼

CSV¤òUTF-8¤ÇÊݸ¤¹¤ë

  • Ä̾ï¤ÎSaveµ¡Ç½¤Ç¤ÏUnicode¤Þ¤Ç¤·¤«»ØÄê¤Ç¤­¤Ê¤¤¤¬¡¢¤¤¤¯¤Ä¤«ÊýË¡¤Ï¤¢¤ë
  • ¥Õ¥ê¡¼¤Î¥â¥¸¥å¡¼¥ë¤ò»ÈÍѤ¹¤ëÊýË¡
  • ADODB.Stream¤ò»È¤¦ÊýË¡
       Dim myFileName As String
       Dim myPath As String
       Dim NewFileName As String
       
       myFileName = ActiveWorkbook.name
       myPath = ActiveWorkbook.Path
       
       Dim outbook As Workbook
       Set outbook = ActiveWorkbook
       Dim sht As Worksheet
    
       Dim i As Integer
       For i = 1 To ActiveWorkbook.Worksheets.Count
           Windows(myFileName).Activate
           NewFileName = ActiveWorkbook.Worksheets(i).name
           Set sht = outbook.Worksheets(i)
           Dim StreamIn As Object
           Set StreamIn = CreateObject("ADODB.Stream")
           With StreamIn
               .Open
               .Charset = "shift_jis"
               .Type = 2
               .Position = 0
           End With
       
           Dim StreamOut As Object
           Set StreamOut = CreateObject("ADODB.Stream")
           With StreamOut
               .Open
               .Charset = "UTF-8"
               .Type = 2
               .Position = 0
           End With
       
           Dim row As Integer
           row = sht.UsedRange.Cells(sht.UsedRange.Count).row
    
           Dim line As Integer
           line = sht.UsedRange.Cells(sht.UsedRange.Count).Column
    
           Dim fileName As String
           fileName = myPath & "\" & NewFileName & ".dat"
    
           Dim r As Integer
           For r = 1 To row
               Dim l As Integer
               For l = 1 To line - 1
                   StreamIn.WriteText sht.Cells(r, l) & ","
               Next
               StreamIn.WriteText sht.Cells(r, line), 1
           Next
           
           StreamIn.SetEOS
           StreamIn.Position = 0
    
           StreamIn.CopyTo StreamOut
           StreamOut.SetEOS
           StreamOut.Position = 0
           
           StreamOut.SaveToFile fileName, 2
           StreamIn.Close
           StreamOut.Close
           Set StreamIn = Nothing
           Set StreamOut = Nothing
       Next i

Shift JISʸ»úÎó¤òUTF-8¤Ë

Public Function encodeUTF8(ByRef strUni As String) As Byte()
   encodeUTF8 = ADOS_Encode("UTF-8", strUni)
End Function

Private Function ADOS_Encode(ByVal cset As String, ByRef strUni As String) As Byte()
   Dim objStm As ADODB.Stream
   Set objStm = New ADODB.Stream
   objStm.Open
   objStm.Type = adTypeText
   objStm.Charset = cset
   objStm.WriteText strUni

   objStm.Position = 0
   objStm.Type = adTypeBinary
   Select Case UCase(cset)
     Case "UNICODE", "UTF-16"
       objStm.Position = 2
     Case "UTF-8"
       objStm.Position = 3
   End Select
   ADOS_Encode = objStm.Read()

   objStm.Close

End Function

ÉÁ²èÍÞÀ©

Application.ScreenUpdating = false

¥·¡¼¥ÈʤÙÂØ¤¨¥µ¥ó¥×¥ë

  • £±¥·¡¼¥ÈÌܤÎ2¹ÔÌÜ2ÎóÌܤ«¤é¥·¡¼¥È̾¤òʤ٤Ƥª¤­¡¢¤½¤Î½çÈ֤ˣ²ÈÖÌܰʹߤΥ·¡¼¥È¤òÆþ¤ìÂØ¤¨¤ë¥Þ¥¯¥í¤ÎÎã¡Ê¤Á¤ç¤Ã¤È¥Ð¥°¤Ã¤Æ¤ë¤«¤â¡Ä¡Ë
Sub ¥·¡¼¥ÈʤÙÂØ¤¨()

   Dim bk As Workbook
   Set bk = ThisWorkbook

   Dim sht As Worksheet
   Set sht = ActiveSheet

   Dim names() As String
   Dim i As Integer

   '¥·¡¼¥È̾ÆÉ¤ß¹þ¤ß
   Dim j As Integer
   j = 0
   For i = 2 To 1000 '¤È¤ê¤¢¤¨¤º1000¥·¡¼¥È¤Þ¤Ç
       If sht.Cells(i, 2) <> "" Then
           ReDim Preserve names(j)
           names(j) = sht.Cells(i, 2)
           j = j + 1
       Else
           Exit For
       End If
   Next

   For i = 0 To UBound(names)
       Dim wsht As Worksheet
       Set wsht = bk.Worksheets(names(i))
       Call wsht.Move(After:=bk.Worksheets(1 + i))
   Next

   MsgBox ("OK")

End Sub

Excel¥·¡¼¥È¥¢¥ë¥Õ¥¡¥Ù¥Ã¥È½çʤÙÂØ¤¨

¥·¡¼¥È¾å¤Î¥·¥§¥¤¥×¤Î¿§¤ò¤Þ¤È¤á¤Æ¹õ¤ËÌ᤹Îã

Sub Macro1()
   Dim i As Integer
   Dim acs As Worksheet
   Set acs = ActiveSheet
   For i = 1 To acs.Shapes.Count
       Dim shap As Shape
       Set shap = acs.Shapes(i)
       With shap
           acs.Activate
           shap.Select
           DoEvents
           If (shap.Type = msoAutoShape) Then
               If shap.AutoShapeType = msoShapeMixed Then
                   '¥³¥ó¥Ô¥å¡¼¥¿¿Þ¤È¤«
               ElseIf shap.AutoShapeType = msoShapeRoundedRectangle Then
                   '³Ñ¤Î´Ý¤¤»Í³Ñ
                   Selection.Font.ColorIndex = xlAutomatic
               End If
               
           ElseIf shap.Type = msoLine Then
               Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
               Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
           
           ElseIf shap.Type = msoTextBox Then
               Selection.Font.ColorIndex = xlAutomatic
           End If
       End With
   Next
End Sub

ÎóÉý¤ò¹ç¤ï¤»¤ë

   'ost ¤ÏÂоݥ·¡¼¥È
   ost.Activate
   ost.Range(ost.Cells(1, 1), ost.Cells(osr, 8)).Columns.AutoFit
  • columns¤ËÂФ·¤Æ¹Ô¤¦¤Î¤¬¥Ý¥¤¥ó¥È

¥Þ¥¯¥í¤Î¤¢¤ë¥Ö¥Ã¥¯

  • ThisWorkbook¤Ç»²¾È

¥·¥§¥¤¥×¤òºÇÇØÌÌ¤Ë°ÜÆ°

Selection.ShapeRange.ZOrder msoSendToBack 'ºÇÇØÌÌ¤Ë°ÜÆ°

AddTextBox ¤ËÅϤ¹ºÂɸ¤ÎÅϤ·Êý

¥Ö¥Ã¥¯¤Î¥·¡¼¥È¥¤¥ó¥Ç¥Ã¥¯¥¹¤òºî¤ë

  • ºÇ½é¤Î¥·¡¼¥È¤Ë¡ÖÌܼ¡¡×¤È¤¤¤¦Ì¾Á°¤ò¤Ä¤±¤ë¤Î¤Ç¤¢¤é¤«¤¸¤áÍѰդ·¤Æ¤ª¤¯
    Sub MakeIndex()
       
       Dim s_¥·¡¼¥È̾() As String
       
       Dim mokuji As Worksheet
       Set mokuji = Worksheets(1)
       mokuji.Name = "Ìܼ¡"
       
       '¡ÔÌܼ¡¡Õ¥·¡¼¥È¾ðÊó
       Dim row As Integer
       Dim col As Integer
       row = 1
       col = 2
    
       '  ¥·¡¼¥È̾¼èÆÀ
       mokuji.Select
       Dim J As Integer
       For J = 1 To Worksheets.Count
           ReDim Preserve s_¥·¡¼¥È̾(J)
           s_¥·¡¼¥È̾(J) = Worksheets(J).Name
       Next J
       
       mokuji.Activate
    
       '  ¼èÆÀ·ë²ÌÈ¿±Ç
       Dim K As Integer
       For K = 2 To UBound(s_¥·¡¼¥È̾)
    
           Dim sht_name As String
           sht_name = s_¥·¡¼¥È̾(K)
           If sht_name <> "" Then
               Dim rnt As Range
               Set rnt = mokuji.Cells(K, col)
               mokuji.Hyperlinks.Add _
                   Anchor:=rnt, _
                   Address:="", SubAddress:="'" & sht_name & "'!A1", TextToDisplay:=sht_name
               mokuji.Cells(K, col).Select
           End If
    
       Next K
    End Sub

¥·¡¼¥È¤Ë²èÁü¤ò¼è¤ê¹þ¤ß¡¢¤½¤ÎÀê¤á¤Æ¤¤¤ëÈϰϤᦲ¼¥»¥ë¤òÆÀ¤ë

Dim acs As Worksheet
Set acs = ActiveSheet
acs.Cells(1, 1).Select
acs.Pictures.Insert(²èÁü¤Îpath).Select
Dim r As Range
Set r = acs.Pictures(1).BottomRightCell

¤¤¤é¤Ê¤¤¥·¡¼¥È¤ò¾Ã¤¹

   Application.DisplayAlerts = False '·Ù¹ðÍÞÀ©
   With outbook
       'ËÜÅö¤Ï£³¤Ä¤È¤Ï¸Â¤é¤Ê¤¤¤¬¡ÊExcel¤ÎÀßÄê¤Ë¤è¤Ã¤ÆÊѤï¤ë¤Î¤Ç¡Ë¡¢¤È¤ê¤¢¤¨¤º
       .Worksheets("Sheet1").Delete
       .Worksheets("Sheet2").Delete
       .Worksheets("Sheet3").Delete
   End With
  • ¢¨¥·¡¼¥È¿ô¤ò£°¤Ë¤Ï¤Ç¤­¤Þ¤»¤ó¤Î¤ÇÃí°Õ

¥×¥í¥°¥é¥à¤ÎƱ´üŪ¤Ê¼Â¹Ô

ɽ¼¨ÇÜΨ¤òÊѤ¨¤ë

ActiveWindow.Zoom = 75

¥Ï¥¤¥Ñ¡¼¥ê¥ó¥¯ºîÀ®

ɽ¼¨Ê¸»úÎó = "hoge"
¥¢¥É¥ì¥¹ = "http://www.kernel-net.ne.jp/tech/"
Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
       Address:=¥¢¥É¥ì¥¹, TextToDisplay:=ɽ¼¨Ê¸»úÎó
  • ºï½ü
    Range("A1").Hyperlinks.Delete
    Range("A1").ClearContents

°õºþÀßÄê ±¦²¼¤Ë¥Ú¡¼¥¸¿ô¤òÆþ¤ì¤ë

ActiveSheet.PageSetup.RightFooter = "&P/&N"

°õºþÈϰϤÎÀßÄê

ActiveSheet.PageSetup.PrintArea = "$A$1:$N$83" 'A1·Á¼° Range¤Ç¤Ï¥À¥á¤Ç¤¹

Range¤«¤éA1·Á¼°¤Îʸ»úÎó¤òÆÀ¤ë¤Ë¤Ï

str = Cells(row, col).Address

Worksheets.Add¤ÎAfter°ú¿ô¤Ê¤É¤ÇÅϤ¹¤Î¤Ï¥·¡¼¥È̾¤Ç¤Ï¤Ê¤¤

  • ¥·¡¼¥È¤ÎÈÖÌܤǤâ¤Ê¤¤¡£Worksheet¤Î¥ª¥Ö¥¸¥§¥¯¥È¤òÅϤµ¤Ê¤¤¤È¤¤¤±¤Ê¤¤¤Î¤ÇÃí°Õ
    '¥Ö¥Ã¥¯ËöÈø¤Ø¤Î¥·¡¼¥ÈÄɲÃ
    Worksheets.Add after:=Worksheets(Worksheets.Count)
  • Worksheet.Move ¤ä .Copy¤âƱÍÍ

VBA¤Ç¥Ç¡¼¥¿¤¬ÊѤï¤Ã¤¿ÀÚ¤ìÌܤDzþ¥Ú¡¼¥¸¤·¤¿¤¤

  • http://oshiete1.goo.ne.jp/qa1919970.html
    Worksheets(SheetName).Range("B" + Trim$(Str$(rindex))).Activate
    ActiveWindow.SelectedSheets.HPageBreaks.Add ActiveCell '²þ¥Ú¡¼¥¸ÁÞÆþ
    ActiveWindow.SelectedSheets.VPageBreaks.Add ActiveCell

°õºþ²þ¥Ú¡¼¥¸¤òÄ´À°¤¹¤ë

'°õºþ¥Ö¥ì¡¼¥¯°ÌÃÖÈùÄ´À° 13·åÌܤÀ¤Ã¤¿¤é±¦¤Ë£±¤Ä¤º¤é¤¹
'ľÀÜ»ØÄê¤Ç¤­¤Ê¤¤¤Î¤À¤í¤¦¤«?
Function adjust_print(st As Worksheet) As Integer

        Debug.Print (st.Name)
        st.Activate
        st.Cells(1, 14).Select
        
        '¤³¤ì¤Ç¤ÏÊѤï¤Ã¤Æ¤¯¤ì¤Ê¤¤¤è¤¦¤À
        If st.VPageBreaks.Count = 0 Then
            st.VPageBreaks.Add st.Range("N1")
        Else
            st.VPageBreaks(1).Location = st.Range("N1")
        End If
        
        '¤³¤¦¤·¤Ê¤¤¤È¤¢¤ï¤»¤é¤ì¤Ê¤¤¤Î¤À¤í¤¦¤«?
        If st.VPageBreaks(1).Location.Column = 13 Then
            ActiveWindow.View = xlPageBreakPreview
            ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
            ActiveWindow.View = xlNormalView
        End If
        
        st.Cells(1, 1).Select

    adjust_print = 0
End Function

Sub °õºþ°ÌÃÖ¹ç¤ï¤»()
'
    Dim shts As Sheets
    Set shts = ActiveWorkbook.Worksheets
    Dim i As Integer
    Dim st As Worksheet
    
    'Âоݥ·¡¼¥ÈËè
    For i = 4 To shts.Count
        Set st = shts(i)
        Call adjust_print(st)
        DoEvents
    Next
    
End Sub

CSV·Á¼°¤ÇÊݸ¤¹¤ë

ActiveWorkbook.SaveAs Filename:="hoge.csv", FileFormat:=xlCSV, CreateBackup:=False

¥Ç¡¼¥¿¤Î¤¢¤ëºÇ¸å¤Î¹Ô¤òÊÖ¤¹

e=Worksheets("sheet1").Range("A1").End(xlDown).Row

¤â¤·¤¯¤Ï

e=Worksheets("sheet1").Range("A65536").End(xlUp).Row '¥Ç¡¼¥¿Ãæ¤Ë¶õ¤­¹Ô¤¬¤¢¤ë¾ì¹ç
  • ¾å¤Î¤ä¤êÊý¤Ç¤Ï¡¢Îó¤Ê¤é£²Îó°Ê¾å¤Ê¤¤¤È256¤¬Ê֤äƤ·¤Þ¤¦¤Î¤Ç¡¢²¼µ­¤Î¤è¤¦¤Ë¤ä¤ëÊý¤¬¤¤¤¤¤è¤¦¤À¡£
    Dim row As Integer
    row = sht.UsedRange.Cells(sht.UsedRange.Count).row
    
    Dim line As Integer
    line = sht.UsedRange.Cells(sht.UsedRange.Count).Column
  • ¤³¤Î¤ä¤êÊý¤Ë¤Ä¤¤¤Æ¤³¤Á¤é¤Îblog ¤Ç¤´»ØÅ¦¤¢¤ê¡£´¶¼Õ
    ¤³¤ì¤Ï¡¢¥Ç¡¼¥¿¤ÎÆþÎϤÎ̵ͭ¤Ë´Ø¤ï¤é¤º¡¢¥»¥ë¤Î°ìÉô¤Ë½ñ¼°ÀßÄê¤Ê¤É¤¬¤µ¤ì¤Æ¤¤¤ì¤Ð¡¢
    Í­¸ú¤ÊÈϰϤȤ·¤ÆÃͤòÊÖ¤·¤Þ¤¹¡£
    ¤¹¤Ã¤­¤ê¤È¤·¤Æ¤¤¤Æ¡¢¤¦¤Þ¤¯¹Ô¤­¤½¤¦¤Ç¤¹¤¬¡¢¼Â¤ÏÍî¤È¤··ê¤Ë¤Ê¤Ã¤Æ¤¤¤Þ¤¹¡£

¥´¡¼¥ë¥·¡¼¥¯¤ò¼Â¹Ô¤µ¤»¤ë

'E3¤ÎÃͤ¬0¤Ë¤Ê¤ë¤è¤¦¤ËB3¤òÊѲ½¤µ¤»¤ë¾ì¹ç
Range("E3").GoalSeek Goal:=0, ChangingCell:=Range("B3")

¥Ö¥Ã¥¯¤ò³«¤¤¤Æ¥·¡¼¥ÈËè¤Ë¤Ê¤Ë¤«¤¹¤ë¥µ¥ó¥×¥ë

Function prcBook(bk As String) As Integer
    
    Debug.Print ("-------book:" & bk & "¥¹¥¿¡¼¥È---------------------")
    
    Dim wbk As Workbook
    '»ØÄê xls ¤ò³«¤¯
    'Set wbk = Application.Workbooks(bk)
    Set wbk = Workbooks.Open(bk)
    wbk.Activate
    
    Dim cnt As Integer
    cnt = wbk.Worksheets.Count
    Debug.Assert (cnt > 0)
    Dim i As Integer
    For i = 1 To cnt
        Dim wst As Worksheet
        Set wst = wbk.Worksheets(i)
        
        Call prcSheet(wst)
        
    Next
    
    wbk.Close
    Debug.Print ("-------½èÍý½ª¤ï¤ê---------------------")

End Function

VBA¥×¥í¥¸¥§¥¯¥È¤ò¥í¥Ã¥¯¤¹¤ë

VBA¥Õ¥¡¥¤¥ë¤Î¥Ç¡¼¥¿¹½Â¤


¥È¥Ã¥×   ÊÔ½¸ Åà·ë º¹Ê¬ ¥Ð¥Ã¥¯¥¢¥Ã¥× źÉÕ Ê£À½ ̾Á°Êѹ¹ ¥ê¥í¡¼¥É   ¿·µ¬ °ìÍ÷ ñ¸ì¸¡º÷ ºÇ½ª¹¹¿·   ¥Ø¥ë¥×   ºÇ½ª¹¹¿·¤ÎRSS
Last-modified: 2022-08-13 (ÅÚ) 16:06:52 (6d)