たいぎー公国開発部 - TIPS

Home » Tips » VBA TIPS » Method »

基本的なことしか書いていませんがVBAのTipsです。
Excelで主に使っていたものです。Word、Accessで同じように使えるかどうかまでは分かりません。
また、Excel2007以降でも使用可能です。

おすすめしませんが、VBAは日本語で変数名、関数名を命名することが出来ます。
日本語で変数や関数名を命名すると日本語圏以外のExcelで面倒なことになるので、外国で働く予定のある人はちゃんと英語で命名しましょう(自戒)


  • 選択されたセルの結合を解除する
  • 選択されたセルを結合する
  • 選択されたセルを結合する(文字列は連結する)
  • ブック内検索
  • Range指定された文字列の文字数をカウント
  • 全てのワークシートのカーソルを左上に
  • 対象範囲全てに罫線を引く
  • 行の削除
  • ダウンロードした画像を選択中のセルの位置に貼り付ける

  • 選択されたセルを結合する

    Sub 選択されたセルを結合する()
    ' 選択されたセルを結合する

    Dim 行数 As Long
    Dim 列数 As Long
    Dim 選択範囲 As Variant

    With Selection

       行数 = .Rows.Count
       列数 = .Columns.Count
       選択範囲 = .Cells(1, 1).Address & ":" & .Cells(行数, 列数).Address
       .MergeCells = True

    End With

    End Sub

    △一番上へ

    選択されたセルを結合する(文字列は連結する)

    Sub 選択されたセルを結合する_文字列は連結する()
    ' 選択されたセルを結合する

    Dim 行数 As Long
    Dim 列数 As Long
    Dim 選択範囲 As Variant
    Dim 全文字列 As String
    Dim iRow As Integer
    Dim iColumn As Integer

    '作業中は画面を更新しない
    Application.ScreenUpdating = False
    '確認ダイアログを非表示にする
    Application.DisplayAlerts = False

    With Selection

        行数 = .Rows.Count
        列数 = .Columns.Count

        For iRow = 1 To 行数
            For iColumn = 1 To 列数
               If (Len(.Cells(iRow,iColumn).Value <> 0)) Then
                  全文字列 = 全文字列 & .Cells(iRow, iColumn).Value
               End If
            Next
        Next

        選択範囲 = .Cells(1, 1).Address & ":" & .Cells(行数, 列数).Address
        .MergeCells = True
        .WrapText = True '折り返して全体を表示する
        .Cells(1, 1).Value = 全文字列

    End With

    End Sub

    △一番上へ

    選択されたセルの結合を解除する

    Sub 選択されたセルの結合を解除する()
    '選択されたセルの結合を解除する

    Dim 行数 As Long
    Dim 列数 As Long
    Dim 選択範囲 As Variant

    '作業中は画面を更新しない
    Application.ScreenUpdating = False
    '確認ダイアログを非表示にする
    Application.DisplayAlerts = False

    With Selection

       行数 = .Rows.Count
       列数 = .Columns.Count
       選択範囲 = .Cells(1, 1).Address & ":" & .Cells(行数, 列数).Address
       .MergeCells = False
       .WrapText = False '折り返して全体を表示しない

    End With

    End Sub

    △一番上へ

    ブック内検索

    Sub ブック内検索()
    'ブック内検索
    'インプットボックスを表示し、検索単語を入力する
    '検索対象はブック内の全シートの「カーソルのある列」


    Dim 検索単語 As String
    Dim strWork As String
    Dim i As Integer
    Dim 対象列 As Integer
    Dim 対象範囲 As Integer
    Dim 行 As Integer

    対象列 = Selection.Column
    対象範囲 = 200

    With ActiveWorkbook

        検索単語 = InputBox("検索する単語を入力してください" & vbCrLf&"検索する列は" &str(対象列) & "列目です", "[Book内検索]:" & .Name)
        If (Len(検索単語) = 0) Then
            Exit Sub
        End If

        For i = 1 To .Worksheets.Count
            'B列を検索
            For 行 = 1 To 対象範囲
                strWork= .Worksheets(i).Cells(行, 対象列).Value

                If (InStr(strWork,検索単語) <> 0) Then
                    .Worksheets(i).Activate
                    .Worksheets(i).Cells(行, 対象列).Activate
                    If(MsgBox("次へ", vbOKCancel) <> vbOK) Then
                        ExitSub
                    End If
                End If
            Next
        Next
       i = MsgBox(検索単語 & "の検索を終了しました", , .Name)

    End With

    End Sub

    △一番上へ

    Range指定された文字列の長さを返す

    Function LENS(objRange As Range) As Long
    Dim lngCnt As Long

    Dim lngLength As Long

    lngLength = 0

    For lngCnt = 1 To objRange.Count
    lngLength = lngLength + Len(objRange.Cells(lngCnt))
    Next
    LENS = lngLength
    End Function

    △一番上へ

    全てのワークシートのカーソルを左上に

    Sub 全てのワークシートのカーソルを左上に()

        '確認ダイアログを非表示にする
        Application.DisplayAlerts = False

        Dim iSheet As Integer
        Dim i   As Integer
        iSheet = ActiveSheet.Index
        For i = 1 To Sheets.Count
            With ActiveWorkbook.Sheets(i)
                .Activate
                .Cells(1, 1).Activate
            End With
        Next
        Sheets(iSheet).Activate
        Beep
    End Sub

    △一番上へ

    対象範囲全てに罫線を引く

    指定した開始行から終了行、最初の列から指定した列までに罫線を引きます。
    Excel2003までは引数は全てIntegerでいけたのですが、Excel2007はシート自体の列、行数が拡張されたのでLongでないとOverFlowすることがあります。

    Public Sub DrawCrossLine(ByVal nStartRow As Long, ByVal nEndRow As Long, ByVal nEndColumn As Long)
       
        Range(Cells(nStartRow, 1), Cells(nEndRow, nEndColumn)).Select
       
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With

        Cells(nStartRow, 1).Select
       
    End Sub

    △一番上へ

    行の削除

    指定した位置からシートの最終行まで(CTRL+END)を削除します。

    Public Sub DeleteRow(ByVal nStartRow As Long)
       
        Dim nSelectRow      As Long
        Dim nSelectColumn   As Long
       
        nSelectRow = Selection.row
        nSelectColumn = Selection.column
       
        Range(Cells(nStartRow, 1), ActiveCell.SpecialCells(xlLastCell)).Select
        If (Selection.row = nStartRow - 1) Then
            Cells(nSelectRow, nSelectColumn).Select
            Exit Sub
        End If
        Selection.EntireRow.Delete
        Cells(nSelectRow, nSelectColumn).Select

    End Sub

    ダウンロードした画像を選択中のセルの位置に貼り付ける

    以下のページを参考に、HTTP通信で画像を取得し、Excelに張り付けられるか試した際につくってみたものです。
    そのため、人のソースが混じってます…。
    すいません。

    Private Sub downLoadAndImageFilePaste(ByVal ImagesURL As String)
        Dim objFSO As Object
        Dim HTTP As Object

        Dim url As String

        Dim buffer() As Byte

        Dim tempDirectory As String
        Dim tempFileName As String
        Dim tempFilePath As String

        Dim objShape As Shape

        Dim i As Long

        Dim ShapesCount As Long

        url = Trim(ImagesURL)

        If (Len(url) = 0) Then
            MsgBox "URLが指定されていません", vbCritical
            Exit Sub
        End If


        Set objFSO = CreateObject("Scripting.FileSystemObject")

        tempDirectory = objFSO.GetSpecialFolder(2)
        tempFileName = objFSO.GetTempName()

        tempFilePath = tempDirectory & "\" & tempFileName & ".png"

        Set objFSO = Nothing

        Set HTTP = CreateObject("MSXML2.XMLHTTP")
        HTTP.Open "GET", url, False
        HTTP.send

        buffer = HTTP.responsebody
        If (UBound(buffer) <> 0) Then
            Open tempFilePath For Binary As #1
            For i = 0 To UBound(buffer)
                Put #1, , buffer(i)
            Next
            Close #1
        Else
            MsgBox "取得失敗", vbCritical
            Exit Sub
        End If

        Set HTTP = Nothing


        ShapesCount = ActiveSheet.Shapes.Count

        For i = 1 To ShapesCount
            Set objShape = ActiveSheet.Shapes.Item(1)
            Debug.Print objShape.Type & "MsoShapeType.msoPicture=" & MsoShapeType.msoPicture
            If (objShape.Type = MsoShapeType.msoLinkedPicture) Then
                objShape.Delete
            End If
        Next


        Set objShape = ActiveSheet.Shapes.AddPicture( _
            Filename:=tempFilePath, _
            LinkToFile:=True, _
            SaveWithDocument:=False, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=100#, _
            Height:=100#)
            '---(1)選択位置に画像ファイルを挿入し、変数objShapeに格納
        With objShape '---(2)挿入した画像に対して
            .ScaleHeight 1!, msoTrue '---元の画像ファイルと同じ高さにする
            .ScaleWidth 1!, msoTrue '---元の画像ファイルと同じ幅にする
        End With

    End Sub

    △一番上へ


    inserted by FC2 system