マクロ、流用マクロのコード
| HOME > エクセル上級 > マクロ、流用マクロのコード |
マクロ
マクロのコードです。マクロの記録を利用し、一部修正して作成しました。たぶん。「↑に移動」「↓に移動」「データのコピー」「データの削除」の4種類です。熟練者から見たら汚いコードだとおもいますが、ご容赦くださいませ。ちょっとしたマクロなので実行スピード的に問題が出ることはないでしょう。(^^;)
・↑上に移動Sub data_up()
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
On Error GoTo handleerr
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Select
Selection.Cut
Rows(my_row - 1).Select
Selection.Insert Shift:=xlDown
Range(Cells(my_row - 1, my_Column), Cells(my_row_end - 1, my_Column_end)).Select
Application.ScreenUpdating = True
Exit Sub
handleerr:
Application.CutCopyMode = False
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
On Error GoTo handleerr
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Select
Selection.Cut
Rows(my_row - 1).Select
Selection.Insert Shift:=xlDown
Range(Cells(my_row - 1, my_Column), Cells(my_row_end - 1, my_Column_end)).Select
Application.ScreenUpdating = True
Exit Sub
handleerr:
Application.CutCopyMode = False
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
・ 下に移動
Sub data_down()
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
On Error GoTo handleerr
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Select
Selection.Cut
Rows(my_row_end + 2).Select
Selection.Insert Shift:=xlDown
Range(Cells(my_row + 1, my_Column), Cells(my_row_end + 1, my_Column_end)).Select
Application.ScreenUpdating = True
Exit Sub
handleerr:
Application.CutCopyMode = False
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
On Error GoTo handleerr
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Select
Selection.Cut
Rows(my_row_end + 2).Select
Selection.Insert Shift:=xlDown
Range(Cells(my_row + 1, my_Column), Cells(my_row_end + 1, my_Column_end)).Select
Application.ScreenUpdating = True
Exit Sub
handleerr:
Application.CutCopyMode = False
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
・ データコピー
Sub data_CopyPaste()
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Copy
Rows(my_row_end + 1 & ":" & my_row_end + 1).Insert
'Rows("7:7").Select
'Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Copy
Rows(my_row_end + 1 & ":" & my_row_end + 1).Insert
'Rows("7:7").Select
'Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
・ データ削除
Sub data_delete()
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Select
Selection.Delete Shift:=xlUp
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
Dim my_row As Long
Dim my_Column As Long
Dim my_row_end As Long
Dim my_Column_end As Long
Application.ScreenUpdating = False
my_row = ActiveCell.Row
my_Column = ActiveCell.Column
my_row_end = Selection.Rows.Count + my_row - 1
my_Column_end = Selection.Columns.Count + my_Column - 1
Rows(my_row & ":" & my_row_end).Select
Selection.Delete Shift:=xlUp
Range(Cells(my_row, my_Column), Cells(my_row_end, my_Column_end)).Select
Application.ScreenUpdating = True
End Sub
流用マクロ
こちらで紹介しているマクロは「dzone. blog」の
[Excel VBA] 工程表の作成 -VBAによるShapeの描画- (1)を参考にさせていただいています。そのままではボク的には使いにくい部分があったので改良しました。現在は単純に選択範囲のセルの中心部分にラインを引くようにしています。
Sub solid_line_black()
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 - 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.SchemeColor = 8
.Weight = 1.25
End With
End Sub
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 - 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.SchemeColor = 8
.Weight = 1.25
End With
End Sub
・実線矢印赤色
Sub solid_line_red()
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 - 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.RGB = RGB(255, 0, 0)
.Weight = 1.25
End With
End Sub
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 - 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.RGB = RGB(255, 0, 0)
.Weight = 1.25
End With
End Sub
・点線矢印黒色
Sub dotted_line_black()
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 + 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.DashStyle = msoLineDash
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.SchemeColor = 8
.Weight = 1.25
End With
End Sub
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 + 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.DashStyle = msoLineDash
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.SchemeColor = 8
.Weight = 1.25
End With
End Sub
・点線矢印赤色
Sub dotted_line_red()
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 + 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.DashStyle = msoLineDash
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.RGB = RGB(255, 0, 0)
.Weight = 1.25
End With
End Sub
Dim SentakuTop As Single ' 選択範囲左上座標値 Y
Dim SentakuLeft As Single ' 選択範囲左上座標値 X
Dim SentakuWidth As Single ' 選択範囲幅
Dim SentakuHeight As Single ' 選択範囲高さ
Dim SentakuAddress As String ' 選択範囲アドレス
Dim X0, Y0, X1, Y1 As Variant
' 選択範囲の取得（相対指定のExcel形式：ex. A1:A9）
SentakuAddress = Selection.Address(ColumnAbsolute:=False, RowAbsolute:=False)
' 選択範囲左上の座標値および選択幅、選択高さを取得（ピクセル単位）
With ActiveSheet.Range(SentakuAddress)
SentakuTop = .Top
SentakuLeft = .Left
SentakuWidth = .Width
SentakuHeight = .Height
End With
' 工数ラインの開始座標、終了座標を計算
X0 = SentakuLeft
Y0 = SentakuTop + SentakuHeight / 2 + 0
X1 = SentakuLeft + SentakuWidth
Y1 = Y0
' 工数ラインをプロットする
With ActiveSheet.Shapes.AddLine(X0, Y0, X1, Y1).line
.DashStyle = msoLineDash
.EndArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadStyle = msoArrowheadOval
.ForeColor.RGB = RGB(255, 0, 0)
.Weight = 1.25
End With
End Sub
|
ＰＲ
 |