エクセル作業の高速化ツール　メモ

Module1

Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Sub excel強制表示()
Excel.Application.Visible = True
End Sub

'アクティブブックの名前を取得
Sub getactivebookname(ByRef activebookname As String)
activebookname = Excel.Application.ActiveWorkbook.name
Debug.Print (activebookname)
End Sub

'workbookを取得
Sub getbookobject(ByRef bookobject As Workbook)
Set bookobject = ActiveWorkbook
Debug.Print (bookobject.name)
End Sub

'行削除
Sub 行削除()

'選択位置のレンジを取得
Dim c As Range
Set c = Selection
Debug.Print (c.Row)
Debug.Print (c.Column)

'セル選択用の位置を取得
Dim ro As Integer
Dim co As Integer
ro = c.Row
co = c.Column

'選択した行数を取得
Dim ronum As Integer
ronum = c.Rows.count

'選択したシート名を取得
Dim asname As String
asname = ActiveSheet.name

'削除する前に安全のためシートをコピー
Sheets(asname).Select
Sheets(asname).Copy After:=Sheets(asname)
Sheets(asname).Select

'行を選択して削除
Range(Rows(ro), Rows(ro + ronum - 1)).Select
Selection.Delete Shift:=xlUp

'選択していたセルを選択
Cells(ro, co).Select

End Sub

'行追加
Sub 行追加()

'選択位置のレンジを取得
Dim c As Range
Set c = Selection
Debug.Print (c.Row)
Debug.Print (c.Column)

'セル選択用の位置を取得
Dim ro As Integer
Dim co As Integer
ro = c.Row
co = c.Column

'選択した行数を取得
Dim ronum As Integer
ronum = c.Rows.count

'行を追加
Range(Rows(ro), Rows(ro + ronum - 1)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'選択していたセルを選択
Cells(ro, co).Select

End Sub

'写真挿入ドラッグドロップフォーム
Public Sub picture_insert_Form_Show()

'アクティブブックを取得してファイル名を表示
Dim activebookname As String
Call getactivebookname(activebookname)
Debug.Print (activebookname)
picture_insert.TextBox1.Text = activebookname

'エクセル表示の制御
Excel.Application.Visible = True

'ディスプレイの幅×高さを取得
Debug.Print "ディスプレイ解像度"
Debug.Print GetSystemMetrics(0) & "×" & GetSystemMetrics(1)

Dim display_h As Long
Dim display_w As Long
display_h = GetSystemMetrics(1)
display_w = GetSystemMetrics(0)

'ユーザーフォームのサイズを取得
Dim yform_h As Long
Dim yform_w As Long
yform_h = picture_insert.height
yform_w = picture_insert.width

'画面右端、上端からの余裕
Dim yoyu_h As Long
Dim yoyu_w As Long
yoyu_h = 100
yoyu_w = 100


Debug.Print (display_h - yform_h - yoyu_h)
Debug.Print (display_w - yform_w - yoyu_w)


'ユーザーフォームの表示位置を指定
picture_insert.StartUpPosition = 0
' picture_insert.Top = display_h - yform_h - yoyu_h
' picture_insert.Left = display_w - yform_w - yoyu_w
picture_insert.Top = display_h / 6
picture_insert.Left = display_w / 2.3
Debug.Print (display_h / 6 & " X " & display_w / 2.3)


'ユーザーフォームを表示
picture_insert.Show vbModeless

'ユーザーフォームを最前面に表示



End Sub

'Toolsフォーム起動
Public Sub tools_Form_Show()
'エクセル表示をoff
Excel.Application.Visible = True

'ディスプレイの幅×高さを取得
Debug.Print "ディスプレイ解像度"
Debug.Print GetSystemMetrics(0) & "×" & GetSystemMetrics(1)

Dim display_h As Long
Dim display_w As Long
display_h = GetSystemMetrics(1)
display_w = GetSystemMetrics(0)

'ユーザーフォームのサイズを取得
Dim yform_h As Long
Dim yform_w As Long
yform_h = Tools.height
yform_w = Tools.width

'画面右端、上端からの余裕
Dim yoyu_h As Long
Dim yoyu_w As Long
yoyu_h = 100
yoyu_w = 100


Debug.Print (display_h - yform_h - yoyu_h)
Debug.Print (display_w - yform_w - yoyu_w)


'ユーザーフォームの表示位置を指定
Tools.StartUpPosition = 0
' picture_insert.Top = display_h - yform_h - yoyu_h
' picture_insert.Left = display_w - yform_w - yoyu_w
Tools.Top = display_h / 6
Tools.Left = display_w / 2.3
Debug.Print (display_h / 6 & " X " & display_w / 2.3)
'ユーザーフォームを表示
Tools.Show vbModeless
End Sub

Sub リンクの削除()

'作成中

Range("C5").Select
ActiveWorkbook.BreakLink name:="C:\Users\M0215534\Desktop\ショートカット一覧.xlsm", _
Type:=xlExcelLinks
ActiveWorkbook.Save

End Sub

Sub 名前の削除()

'すべての名前を表示して削除する
Dim name As Object
For Each name In Names
If name.Visible = False Then
name.Visible = True
name.Delete
End If
Next
' MsgBox "すべての名前の定義を表示しました。", vbOKOnly

End Sub

フォーム

picture_insert

Option Explicit

'変数
Dim strFilesPath() As String '取得したファイルパスの配列
Dim fcount As Long '取得したファイルの数

'ユーザーフォームを最上位に表示する記述一式
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const HWND_TOPMOST As Long = -1
Const SWP_NOSIZE As Long = 1
Const SWP_NOMOVE As Long = 2
Private Sub UserForm_Initialize()
Dim hWnd As LongPtr
'最前面に表示するｳｨﾝﾄﾞｳのﾊﾝﾄﾞﾙを取得(UserForm)
hWnd = FindWindow(vbNullString, Me.Caption)
'ｳｨﾝﾄﾞｳを常に最前面に配置
Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub
'----------------------------------------------------------------------------------------

'ドラッグドロップでファイルパスを取得する
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)


Dim i As Long
With Me
AppActivate .Caption 'ユーザーフォームをアクティブにする
.ListView1.ListItems.Clear
If Data.Files.count < 1 Then Exit Sub '引数Data
ReDim strFilesPath(1 To Data.Files.count) '配列数を変更
For i = 1 To Data.Files.count
strFilesPath(i) = Data.Files(i) 'ファイルパスを取得
ListView1.ListItems.Add.Text = strFilesPath(i) 'ファイルパスをリストビューに追加
Debug.Print (strFilesPath(i))
Next
End With

'ファイルの数を取得
fcount = Data.Files.count

End Sub
'ファイルを書式を指定して挿入する
Private Sub BT_insert_Click()

With Excel.Application
.Visible = True
.DisplayAlerts = False
End With
'選択セル位置を取得
Dim selectedcell As Range
Excel.Application.ActiveCell.Select
Dim h As Long
Dim w As Long

Dim i As Long
For i = 1 To fcount
Debug.Print (strFilesPath(i))
ActiveSheet.Pictures.Insert(strFilesPath(i)).Select 'ファイルを挿入

Selection.ShapeRange.IncrementLeft 195
Selection.ShapeRange.IncrementTop 6

'シェイプのサイズを取得
h = Selection.ShapeRange.height
w = Selection.ShapeRange.width


Debug.Print (h)

' ActiveSheet.Pictures.AddPicture2 (strFilesPath(i),msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1, -1,msoPictureCompressTrue)


Next
End Sub
'ドラッグドロップウィンドウを閉じるとき
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'エクセルを表示する
With Excel.Application
.Visible = True
.DisplayAlerts = False
End With
End Sub

フォーム
tools

Option Explicit
'ユーザーフォームを最上位に表示する記述一式
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const HWND_TOPMOST As Long = -1
Const SWP_NOSIZE As Long = 1
Const SWP_NOMOVE As Long = 2
'フォームを開いた時のイベント
Private Sub UserForm_Initialize()
Dim hWnd As LongPtr
'最前面に表示するｳｨﾝﾄﾞｳのﾊﾝﾄﾞﾙを取得(UserForm)
hWnd = FindWindow(vbNullString, Me.Caption)
'ｳｨﾝﾄﾞｳを常に最前面に配置
Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
'ブックを非表示に設定
Windows(ThisWorkbook.name).Visible = False
End Sub
'フォームを閉じるときのイベント
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'ブックを表示に設定
Windows(ThisWorkbook.name).Visible = True
End Sub

'----------------------------------------------------------------------------------------
'色変えテスト
Private Sub CommandButton3_Click()
'アクティブブックを取得
Dim wb As Workbook
Set wb = ActiveWorkbook
Debug.Print (wb.name)

Application.ScreenUpdating = False
'アクティブワークブックを前面に表示
Workbooks(wb.name).Activate
AppActivate Application.Caption 'アプリケーションを更新

Range("D6:D15").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E8").Select
Application.ScreenUpdating = True

'アクティブワークブックを前面に表示
Workbooks(wb.name).Activate
AppActivate Application.Caption 'アプリケーションを更新

End Sub
Private Sub CommandButton4_Click()
'アクティブブックを取得
Dim aaa As Workbook
Call getbookobject(aaa)
Call 行追加
'アクティブワークブックを前面に表示して更新
Workbooks(aaa.name).Activate
AppActivate Application.Caption
End Sub
Private Sub CommandButton5_Click()
'アクティブブックを取得
Dim aaa As Workbook
Call getbookobject(aaa)
Call 行削除
'アクティブワークブックを前面に表示して更新
Workbooks(aaa.name).Activate
AppActivate Application.Caption
End Sub

Private Sub CommandButton2_Click()
''アクティブブックを取得
'Dim wb As Workbook
'Set wb = ActiveWorkbook
'Debug.Print (wb.Name)
'

Windows("ショートカット一覧.xlsm").Activate
Range("E30:E34").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("F31").Select
Windows("ショートカット一覧.xlsm").Activate

End Sub

Private Sub CommandButton1_Click()

'アクティブブックを取得
Dim wb As Workbook
Set wb = ActiveWorkbook
Debug.Print (wb.name)
TextBox1.Text = wb.name
'アクティブワークブックを前面に表示
Workbooks(wb.name).Activate
AppActivate Application.Caption 'アプリケーションを更新

End Sub

ななめ工作R＆D

このブログを検索