Excelエクセルの小ネタ「写真整理」VBAマクロ使用による自動貼付方法(３パターン) скачать в хорошем качестве

Excelエクセルの小ネタ「写真整理」VBAマクロ使用による自動貼付方法(３パターン)

選択した写真を自動で貼り付けるエクセルファイルを 作成しました。VBAを使用しています。 独学で作成しているもので、効率的と は言えないとは思いますが、皆さんの参考になれば 幸いです。 下記に3パターン記載しましたのでコピペして 使用してください。 '------------------------------------------------ Sub 写真貼付1name() 'ファイル名付き 'ファイル読み出し用変数 Dim filename As Variant '写真読み込み用変数 Dim pic As Shape 'ファイルを纏めて読み込む filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True) 'filenameの配列か確認 If IsArray(filename) Then 'ファイル選択数分繰り返す For i = 1 To UBound(filename) 'ファイル名表示 ActiveCell.Offset = filename(i) 'オブシェクト名を省略 With ActiveCell '写真のサイズをセルの大きさに合わせて貼付け Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(i), linktofile:=False, savewithdocument:=True, _ Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4) End With 'セルの貼り付け位置を設定 ActiveCell.Offset(1, 0).Activate Next i End If End Sub '----------------------------------------------------- Sub 写真貼付22()　’2列表示 'ファイル読み出し用変数 Dim filename As Variant Dim t As Long '写真読み込み用変数 Dim pic As Shape 'ファイル読み込み filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True) 'filenameの配列か確認 If IsArray(filename) Then 'ファイル選択数分繰り返す For i = 1 To UBound(filename) Step 2 '2枚=2、3枚=3 For ii = 1 To 2 '行方向枚数分繰り返し 'オブシェクト名を省略 With ActiveCell t = t + 1 'henkou '写真のサイズをセルの大きさに合わせて貼付け Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(t), linktofile:=False, savewithdocument:=True, _ Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4) End With '貼付けセル位置を設定 ActiveCell.Offset(0, 1).Activate '列方向にアクティブセルを移動(行方向,列方向) If t = UBound(filename) Then GoTo sub2 '写真が最終の時終了させる Next ii ActiveCell.Offset(1, -2).Activate '行方向にアクティブセルを移動(行方向,列方向) Next i sub2: End If End Sub '----------------------------------------------------------- Sub 写真貼付33()　’3列表示 'ファイル読み出し用変数 Dim filename As Variant Dim t As Long '写真読み込み用変数 Dim pic As Shape 'ファイルを纏めて読み込む filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True) 'filenameの配列か確認 If IsArray(filename) Then 'ファイル選択数分繰り返す For i = 1 To UBound(filename) Step 3 'step　2枚=2、3枚=3 For ii = 1 To 3 '行方向枚数分繰り返し　2枚=2、3枚=3 'オブシェクト名を省略 With ActiveCell t = t + 1 'henkou '写真のサイズをセルの大きさに合わせて貼付け Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(t), linktofile:=False, savewithdocument:=True, _ Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4) End With '貼付けセル位置を設定 ActiveCell.Offset(0, 1).Activate '列方向にアクティブセルを移動(行方向,列方向) If t = UBound(filename) Then GoTo sub2 '写真が最終の時終了させる Next ii ActiveCell.Offset(1, -3).Activate '行方向にアクティブセルを移動(行方向,列方向) Next i sub2: End If End Sub '----------------------------------------------------------