▼たいぎー公国開発部 - TIPS
Home » Tips » VBA TIPS » Method »
基本的なことしか書いていませんがVBAのTipsです。
Excelで主に使っていたものです。Word、Accessで同じように使えるかどうかまでは分かりません。
また、Excel2007以降でも使用可能です。
おすすめしませんが、VBAは日本語で変数名、関数名を命名することが出来ます。
日本語で変数や関数名を命名すると日本語圏以外のExcelで面倒なことになるので、外国で働く予定のある人はちゃんと英語で命名しましょう(自戒)
▼選択されたセルを結合する
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
▼対象範囲全てに罫線を引く
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)を削除します。
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に張り付けられるか試した際につくってみたものです。
そのため、人のソースが混じってます…。
すいません。
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
指定した開始行から終了行、最初の列から指定した列までに罫線を引きます。
Excel2003までは引数は全てIntegerでいけたのですが、Excel2007はシート自体の列、行数が拡張されたのでLongでないとOverFlowすることがあります。