【Excel-VBA】画像のみ選択して(削除)

Function imgdel() ‘画像のみ一括選択する
Dim chkBox As Excel.CheckBox
Dim objShape As Object
Dim arr() As String
ReDim Preserve arr(0)
Dim sh01 As Worksheet
Set sh01 = Worksheets(“キーワード一覧”)

'選択シートに存在するオブジェクトを取得します。
For Each objShape In sh01.Shapes

    arr(UBound(arr)) = objShape.Name

    'オブジェクトのタイプが画像であるか判定します。
    If objShape.Type = 11 Then ’リンク画像 11

        '画像オブジェクトの名前を配列に追加します。
        arr(UBound(arr)) = objShape.Name

        '値を保持したまま配列を最大インデックスを追加します。
        ReDim Preserve arr(UBound(arr) + 1)

    End If

Next

'空の値を削除します。
If UBound(arr) > 0 Then
ReDim Preserve arr(UBound(arr) - 1)

'画像オブジェクトを選択します。
sh01.Shapes.Range(arr).Select

'選択オブジェクトを削除します。
Selection.Delete
End If

End Function

選択する種別を変更

msoAutoShape 図形/オートシェイプ 1
msoCallout 吹き出し 2
msoChart グラフ 3
msoComment コメント 4
msoGroup グループ化された図形 6
msoLinkedPicture リンク画像 11
msoPicture 画像 13
msoTextBox テキストボックス 17
msoTable 表 19

【Excel-VBA】画像URLからサムネイルをエクセルシートに張り付ける

Function URLPictureInsert() ‘画像インポート 画像アドレスが必要

Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next

Dim sh01 As Worksheet
Set sh01 = Worksheets(“キーワード一覧”)

‘Application.ScreenUpdating = False

row01 = sh01.Cells(Rows.Count, 1).End(xlUp).Row ‘最終行

Set Rng = sh01.Range(“E2:E” & row01)’ここに画像アドレスを入れる
For Each Cell In Rng
filenam = Cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = Cell.Column + 1
Set xRg = Cells(Cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height – .Height) / 2
.Left = xRg.Left + (xRg.Width – .Width) / 2
End With
lab:
Set Pshp = Nothing
Range(“A2”).Select
Next
‘Application.ScreenUpdating = True
End Function

【Excel-VBA】辞書関数を使って重複を除外してカウントする

Sub tyuumosuu() ‘件数カウント 注文番号重複除外
Dim i As Long
Dim j As Long
Dim maxRow As Long

Dim strMat, lngNum
Dim sh1 As Worksheet
Set sh1 = Worksheets(“未出荷レポート”)
Dim sh2 As Worksheet
Set sh2 = Worksheets(“出荷表”)
Dim dic
Set dic = CreateObject(“Scripting.Dictionary”)

lrwo = sh1.Cells(Rows.Count, 1).End(xlUp).Row ‘最終行

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual ‘自動計算停止(手動計算)

j = 2 ‘リスト書き出し開始行

maxRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To maxRow
    strMat = sh1.Cells(i, 1).Value


    If dic.Exists(strMat) Then’重複してたら何もしない

    Else
        dic.add (sh1.Cells(i, 1).Value), j’重複してなければデータ追加
        j = j + 1
    End If
Next i

sh2.Cells(3, 3).Value = “注文件数 ” & j – 2 & “件 出荷個数”

Application.Calculation = xlCalculationAutomatic '自動計算開始
Application.ScreenUpdating = True '画面描画再開

End Sub

【Excel-VBA】配列変数を使って大量のデータを一気に処理する

最初の配列MyArray1でデータを変数内にまとめて納めるMyArray1 = Range(“A2:C” & row01) もう一つの配列に結果を納めるReDim MyArray2(1 To row01, 1 To 2) 最後に範囲指定した場所に一気に放り込むRange(“D2:E” & row01) = MyArray2

Sub tesut02()
Dim i As Long
Dim MyArray1
Dim MyArray2
Dim sh01 As Worksheet
Set sh01 = Worksheets(“メーカー在庫まとめ”)
row01 = sh01.Cells(Rows.Count, 2).End(xlUp).Row ‘最終行

MyArray1 = Range(“A2:C” & row01)
ReDim MyArray2(1 To row01, 1 To 2)

For i = LBound(MyArray1, 1) To UBound(MyArray1, 1)
    MyArray2(i, 1) = MyArray1(i, 1) & "M" & MyArray1(i, 2)
    MyArray2(i, 2) = MyArray1(i, 3)
Next

Range(“D2:E” & row01) = MyArray2

【VBA+Chromedriver】Chromeウインドウ操作

’Chromeを動かし始めた時に邪魔なので画面サイズを半分にして右端に寄せる

Private Declare Function GetSystemMetrics _
Lib “user32” _
(ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1

    myX = GetSystemMetrics(SM_CXSCREEN) '画面の幅を取得
    myY = GetSystemMetrics(SM_CYSCREEN) '画面の高さを取得
    myX = myX / 2   '画面の幅を半分
    myY = myY - 50
    Driver.Window.SetPosition myX, 20  '画面の幅を半分の位置(右側にウインドウを移動)
    Driver.Window.SetSize myX, myY  'ウインドウの高さは-50にして幅は半分

【Excel-VBA】CSVインポート文字化けしない 1カラムづつ文字列に指定する

Sub notmojibake()

Dim sh1 As Worksheet
Set sh1 = Worksheets(“取込シート”) ‘CSVデータを取込用シート

sh1.Range(“A1”).CurrentRegion.ClearContents ‘ 取込シート を全クリア
Application.ScreenUpdating = False ’ 画面描画 停止
Application.Calculation = xlCalculationManual ‘自動計算停止(手動計算)

‘—–データのある初期フォルダ指定(無くてもOK)———————–
Dim Path As String, WSH As Variant
Set WSH = CreateObject(“WScript.Shell”)
Path = WSH.SpecialFolders(“Desktop”)
Path = Replace(Path, “Desktop”, “Downloads”)
ChDrive “C”
ChDir Path ‘ファイル情報変更前にカレントフォルダを変えると良い

‘—– データのある 初期フォルダの指定完了———————–

’ここから本題のコード
Target = Application.GetOpenFilename(Filefilter:="CSVファイル(*.csv),*.csv")

‘読み込むファイル
Dim strFilePath As String
strFilePath = Target

Dim queryTb As QueryTable
Set queryTb = sh1.QueryTables.add(Connection:=”TEXT;” & strFilePath, _
Destination:=sh1.Range(“A1”)) ‘ CSV を開く
With queryTb
 .TextFilePlatform = 932 ‘ 文字コードを指定
 .TextFileParseType = xlDelimited ‘ 区切り文字の形式
 .TextFileCommaDelimiter = True ‘ カンマ区切り
 .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)   ‘書式 1一般 2文字列 カラムの数だけ書式を設定 20列なら20個2を書く
 .RefreshStyle = xlOverwriteCells ‘ セルに上書き
 .Refresh ‘ データを表示
 .Delete ‘ CSVファイルとの接続を解除
End With

Application.Calculation = xlCalculationAutomatic '自動計算開始
Application.ScreenUpdating = True '画面描画再開

MsgBox ("インポート完了")

End Sub

【Excel-VBA】エクセルで押したボタンの名前を取得して使用する

str_text = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text ‘ボタン名取得

If Len(str_text) < 1 Then ‘名前が1文字以上でなければ
MsgBox “未使用のボタンです”
GoTo Label01’適当な場所に飛ばす
End If

【Excel-VBA】VBAで簡単なツールを作るときに定型文的なメモ

Sub test()
Dim sh01 As Worksheet
Set sh01 = Worksheets(“シート名”)
Application.Calculation = xlCalculationManual ‘自動計算停止
Application.ScreenUpdating = False ‘画面描画停止
Application.DisplayAlerts = False ‘ディスプレイアラート停止
‘————————————————————————-
row01 = sh01.Cells(Rows.Count, 2).End(xlUp).Row ‘最終行
chk = Cells(row01, 1).Value

’———ここにプログラムを記入


Application.Calculation = xlCalculationAutomatic ‘自動計算開始
Application.ScreenUpdating = True ‘画面描画再開
  Application.DisplayAlerts = True ‘ディスプレイアラート再開
End Sub

【Excel-VBA】VBAのパスワード忘れてしまった

①パスワードを忘れてしまったエクセルを開く

②新規Bookを開く

③新規Bookに下記コードをコピペして Sub VBAパスワード解除() を実行

32bit版 Excel

MyDialogBoxParamater = MyDialogBoxParamater(hInstance, pTemplateName, hWndParent, lpDialogFunc, dwInitParam)
HookFlag
End If
End Function

Public Function HookFlag() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As Long
Dim OriginProtect As Long

HookFlag = False
projectFunction = GetProcAddress(GetModuleHandleA(“user32.dll”), “DialogBoxParamA”)
If VirtualProtect(ByVal projectFunction, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal projectFunction, 6
If TmpBytes(0) <> &H68 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal projectFunction, 6
p = GetPtr(AddressOf MyDialogBoxParamater)
HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3
MoveMemory ByVal projectFunction, ByVal VarPtr(HookBytes(0)), 6
Flag = True
HookFlag = True
End If
End If
End Function

Sub VBAパスワード解除()
If HookFlag Then
MsgBox “VBAパスを解除しました。”, vbInformation, “成功しました。”
End If
End Sub

64bit版 Excel

Public Const PAGE_EXECUTE_READWRITE = &H40

Public Declare PtrSafe Sub MoveMemory Lib “kernel32” Alias “RtlMoveMemory” (Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
Public Declare PtrSafe Function VirtualProtect Lib “kernel32” (lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
Public Declare PtrSafe Function GetModuleHandleA Lib “kernel32” (ByVal lpModuleName As String) As LongPtr
Public Declare PtrSafe Function GetProcAddress Lib “kernel32” (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Public Declare PtrSafe Function DialogBoxParam Lib “user32” Alias “DialogBoxParamA” (ByVal hInstance As LongPtr, ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim projectFunction As LongPtr
Dim Flag As Boolean

Public Function GetPtr(ByVal Value As LongPtr) As LongPtr
GetPtr = Value
End Function

Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal projectFunction, ByVal VarPtr(OriginBytes(0)), 6
End Sub

Public Function MyDialogBoxParamater(ByVal hInstance As LongPtr, ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParamater = 1
Else
RecoverBytes
MyDialogBoxParamater = MyDialogBoxParamater(hInstance, pTemplateName, hWndParent, lpDialogFunc, dwInitParam)
HookFlag
End If
End Function

Public Function HookFlag() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As LongPtr
Dim OriginProtect As LongPtr

HookFlag = False
projectFunction = GetProcAddress(GetModuleHandleA(“user32.dll”), “DialogBoxParamA”)
If VirtualProtect(ByVal projectFunction, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal projectFunction, 6
If TmpBytes(0) <> &H68 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal projectFunction, 6
p = GetPtr(AddressOf MyDialogBoxParamater)
HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3
MoveMemory ByVal projectFunction, ByVal VarPtr(HookBytes(0)), 6
Flag = True
HookFlag = True
End If
End If
End Function

Sub VBAパスワード解除()
If HookFlag Then
MsgBox “VBAパスを解除しました。”, vbInformation, “成功しました。”
End If
End Sub