文字追加マクロ

Sub addString_Exe(n As Integer)
'各セルの前後に文字を追加する
    Dim msg             As String
    Dim strForward      As String
    Dim strBack         As String    
    
    msg = "まず前方" & n & "文字目に追加する文字を入力して下さい。空欄でも構いません。"
    'Application.InputBoxのType
    '0:数式
    '1:数値
    '2:文字列
    '8:セル参照
    strForward = Application.InputBox(msg, Title:="前方追加文字列", Type:=2)
    
    
    '文字形式(Type:=2)のInputBoxでは、キャンセルが押されたとき「False」という文字が返される。
    'StrConvのvbLowerCaseを用いて全て小文字に変換する。
    If StrConv(strForward, vbLowerCase) = "false" Then Exit Sub
    
    msg = "次に、後方に追加する文字を入力して下さい。空欄でも構いません。"
    msg = msg & vbCrLf & "後方追加文字列：　" & strForward
    
    strBack = Application.InputBox(msg, Title:="後方追加文字列", Type:=2)
    
    If StrConv(strBack, vbLowerCase) = "false" Then Exit Sub    
   
    On Error Resume Next
    Dim eachRng As Range
    
    Application.ScreenUpdating=False'描画省略

    '選択範囲の各セルの数式について、n文字めに前方追加文字列を追加
    'また、後方追加文字列を追加。
    For Each eachRng In Selection
        eachRng.Formula = Left(eachRng.Formula, n) & strForward & Mid(eachRng.Formula, n + 1) & strBack
    Next eachRng    
    
End Sub

Sub addStringForwardAndBack()
'単純に各セルの前後に文字を追加する
    Call addString_Exe(0)
End Sub

Sub addStringForwardAndBack01()
'1文字(主に、 「=」 文字を想定)あけた後に、各セルの前後に文字を追加する
    Call addString_Exe(1)
End Sub

実用マクロ集

 

SCマクロ

Sub 指定範囲をクリア()
Selection.Clear
End Sub
Sub 最終行へ()
Cells(Rows.Count, Selection.Column).End(xlUp).Select
End Sub

 

マクロ集


'最終行の取得
Sub 最終行()
Cells(Rows.Count, 1).End(xlUp).Row
End Sub

'メッセージボックス
MsgBox "おはよう", vbOKCancel, "タイトル"

'インプットボックス
Dim a As String
a = InputBox("何か入力して下さい。", "タイトル", "デフォルト文字列")

'小数点２桁固定の書式設定
Range.NumberFormatLocal = "0.00"

'セルを結合して中央揃え
Range("セル範囲").HorizontalAlignment = xlCenter
Range("セル範囲").MergeCells = True

'フォントの色を赤に
Range("セル範囲").Font.Color = vbRed

'セルを塗りつぶす
Range("セル範囲").Interior.Color = vbRed

'セル範囲に格子枠線
Range("セル範囲").Borders.LineStyle = xlContinuous

'セル範囲の外枠に枠線
Range("セル範囲").BorderAround _
LineStyle:=xlContinuous, Weight:=xlMedium, Color:=vbRed

'ブック、シートを指定
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1") = "文字"

'セルのコピペ
Sheets("Sheet1").Range("A1").Copy Sheets("Sheet2").Range("A1")

'値のみ貼り付け
Worksheets("Sheet1").Range("A1:B10").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial _
Paste:=xlPasteValues

'書式設定VBA関数
MsgBox Format(Cells(1, 1), "yyyy年mm月dd日")

'置換
MsgBox Replace("123aAbBcC", "A", "Z") '123aZbBcCになる

'文字位置検索
MsgBox InStr("123aAbBcC", "A") '5になる

'ワークシート関数を使用
Range("B1") = WorksheetFunction.CountA(Columns(1))

'全てのワークシートを印刷
Dim ws As Worksheet
For Each ws In Worksheets
ws.PrintPreview
Next ws

'ワークブックを開く
Dim wb As Workbook
Set wb = Workbooks.Open(FileName:="C:\User\sample.xls")

'ウインドウ枠の固定
Workbooks("Book1.xls").Worksheets("Sheet2").Activate
Range("B2").Select
ActiveWindow.FreezePanes = True

'プリンターを指定して印刷
Worksheets(1).PrintOut ActivePrinter:="プリンター名"

'ファイルを指定して開く
Dim FileName As Variant
FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
If FileName = False Then
Exit Sub
End If
Workbooks.Open FileName

'印刷ダイアログを開く
Dim rtn As Boolean
Sheets(1).Select
rtn = Application.Dialogs(xlDialogPrint).Show
Select Case rtn
Case True
MsgBox "印刷されました。"
Case False
MsgBox "印刷がキャンセルされました。"
End Select

'セル範囲のリサイズ
Range("A1:A3").Resize(, 3).Select
'A1: A3セル範囲を､3列に変更し､A1: C3セル範囲に

'セル範囲のオフセット
Range("A1").Offset(3, 3).Select
'A1セルを､行方向に3､列方向に3移動した､D4セルに

 

高速化マクロ

'以下、下記のコードのことを「高速化基本マクロ」と呼ぶ。
Sub appSet()
'マクロ処理中に、描画など余計なものを省略して高速化
With Application
.ScreenUpdating = False '描画を省略
.Calculation = xlCalculationManual '手動計算
.DisplayAlerts = False '警告を省略。
.EnableEvents = False 'DisplayAlertsよりこちらを設定した方が良い？
End With
End Sub

Sub appReset()
'描画などの設定をリセット
With Application
.ScreenUpdating = True '描画する
.Calculation = xlCalculationAutomatic '自動計算
.DisplayAlerts = True '警告を行う
End With
End Sub

 

目次作成マクロ

Sub makeSheetsContent()
'シート目次を作る
Dim arr As Variant
Dim ws As Worksheet
Dim rng As Range
Dim buf As String
Dim i As Integer
Dim wsNum As Integer

Call appSet
wsNum = Worksheets.Count 'シートの数。見出しも作成するために1加えておく

ReDim arr(1 To wsNum, 1 To 2)
'まず見出しをセット
For i = 1 To wsNum
arr(i, 1) = i '番号
arr(i, 2) = Worksheets(i).Name 'シート名
Next i

Worksheets.Add before:=Worksheets(1) 'シート名一覧のシート
Set ws = ActiveSheet

ws.Cells(1, 1).Value = "№"
ws.Cells(1, 2).Value = "シート名"
ws.Cells(2, 1).Resize(wsNum, 2).Value = arr

For i = 1 To wsNum
Set rng = ws.Cells(i + 1, 2) 'シート名を書いたセル
buf = arr(i, 2) 'シート名
ws.Hyperlinks.Add Anchor:=rng, Address:="", _
SubAddress:="'" & buf & "'" & "!$A$1", TextToDisplay:=buf 'リンクも追加
Next i

Rows(1).HorizontalAlignment = xlCenter '横方向は中央揃え
Cells(1, 1).Resize(1, 2).EntireColumn.AutoFit '列幅の自動調整

Call appReset
End Sub

Sub appSet()
'マクロ処理中に、描画など余計なものを省略して高速化
With Application
.ScreenUpdating = False '描画を省略
.Calculation = xlCalculationManual '手動計算
.DisplayAlerts = False '警告を省略。
' .EnableEvents = False 'DisplayAlertsよりこちらを設定した方が良いのかな？
End With
End Sub

Sub appReset()
'描画などの設定をリセット
With Application
.ScreenUpdating = True '描画する
.Calculation = xlCalculationAutomatic '自動計算
.DisplayAlerts = True '警告を行う
End With
End Sub

シート表示マクロ

Sub TEST()

Dim WsName(1 To 3) As Variant
Dim flag As Long
Dim i As Long

WsName(1) = "Sheet3"
WsName(2) = "Sheet8"
WsName(3) = "Sheet6"

Dim WS As Worksheet

For Each WS In Worksheets
flag = 0
For i = 1 To 3
If WS.Name = WsName(i) Then
flag = 1
Next
If flag = 0 Then
WS.Visible = False
ElseIf flag = 1 Then
WS.Visible = True
End If
Next

End Sub

エクセルマクロ　合計まるめ


Sub 工種合計まるめ()
Dim b As Long
Dim i As Long
Dim k As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) <> "" Then
Cells(i, 4) = WorksheetFunction.Sum(Range("F" & i, "J" & i))
b = Range("B" & i).Value
k = -(Log(b) / Log(10))
Cells(i, 3) = WorksheetFunction.Round(Range("D" & i), k)
End If
Next

End Sub
Sub データ抽出()
Dim drng As Range
Dim i As String
ActiveSheet.AutoFilterMode = False
Set drng = Range("N3").CurrentRegion
i = Range("Q2").Value

drng.AutoFilter field:=1, Criteria1:=i & "*"


End Sub
Sub データ挿入()
Dim i As Long
i = Range("R2").Value

Rows(i).Insert
Selection.Copy Range("A" & i)
End Sub

空白セルを消去上詰め、段落分け、列を挿入

Sub 空白行を上詰め()
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp
End Sub
 
Sub 整理()
Selection.CurrentRegion.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Columns("B:C").Insert
Dim i As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Left(Cells(i, 1), 2) = " " Then
Cells(i, 3) = Cells(i, 1)
Cells(i, 1).Clear
ElseIf Left(Cells(i, 1), 1) = " " Then
Cells(i, 2) = Cells(i, 1)
Cells(i, 1).Clear
End If
Next i
End Sub