PR
Free Space
QOLを良好に保つための方策
☆更年期障害に高野豆腐が効果
絶大！って、ほんまかいな？？
（上記の記事は、販売目的の広告ではありません）
Freepage List
【ご利用規定 ／ サポート範囲】
＊＊＊【カエル８２１さん】＊＊＊
＊＊＊【俵のねずみさん】＊＊＊
＊＊＊＊＊＊＊＊＊＊＊＊
フリーページ作成マニュアル
宇宙散歩
ＦＣ２ホームページとのリンクについて
MSNフォトとのリンクについて
【 ＶＢＡサンプルプログラム 】
☆エコ・ソート／サンプル 〔1〕
☆エコ・ソート／サンプル 〔2〕
☆エコ・ソート／サンプル 〔3〕
☆エコ・RDB 〔1〕ＲＤＢシートの初期化
☆エコ・RDB 〔2〕サンプルデータの作成
☆エコ・RDB 〔3〕レコード番号の作成
☆エコ・RDB 〔4〕マスタデータ＋IDの挿入
☆エコ・RDB 〔5〕レコード番号の取得_SUB
☆エコ・RDB 〔6〕データ＋IDの挿入＿SUB
☆エコ・RDB 〔7〕マスタデータ＋IDの削除
☆エコ・RDB 〔8〕データ＋IDの削除＿SUB
☆エコ・RDB〔9〕マスタ＋IDのセットアップ
☆エコ・RDB 〔10〕マスタデータを一件検索
☆エコ・RDB 〔11〕一件のデータを検索_SUB
☆エコ・RDB 〔12〕ＩＤの並びをチェック
＊＊【 ピクセル物差し 】＊＊
サンプルページ
サンプルページ２
＊＊＊＊＊麗華さん＊＊＊＊＊
☆Windowsミニテク ／その2 【増補･改訂】
keiちゃん
keiちゃん２
チユタンさん
文字色比較
フリーページの更新方法
SampleTEST
TEST
掲載中止チェーンメール
☆掲載済みブログ記事のバックアップ
江戸川心歩さん
冬ソナ
☆じゃまな電柱の除去
☆じゃまな電線の除去
☆祝！仕事復帰への第一歩♪☆
☆祝♪楽天おすすめブログ掲載！！
☆その日暮らしの手帳☆ さん
☆ブログＨＯＭＥ
FileDialog オブジェクトの使い方
Joy nana さん CDデビューのお祝い♪
ライセンス表記
☆脳梗塞の予後の食事療法
Keyword Search
▼キーワード検索
寺田屋の龍馬
ぷらぷらねっとへようこそ...！ 小生、昭和の時代からのパソコンオタクで、主に SocketＡＭ２マザーとアスロンで自作ＰＣを製作しているロートルオタクですが、本業はＨＰの作成＆プログラマーです。ロートル故にお役に立てそうなご質問 歓迎！
Calendar
カレンダー
俵のねずみさん
「恋心」「人魚姫」… 47弦の詩人さん
『猿の惑星』を見る…
花の旅さん
ひろきちファミリー… Hiro吉 Evoさん
何の日=つぼんち16 つぼんち１６さん
コロンの部屋 ポッチャリコロンさん
☆あいのマイペースブ… あいたろう３３さん
カエルのお池♪ カエル８２１さん
お気楽うさこの不思… keiko-0521-さん
けろころり keroko*さん
「恋心」「人魚姫」… 47弦の詩人さん
『猿の惑星』を見る…
花の旅さんひろきちファミリー… Hiro吉 Evoさん
何の日=つぼんち16 つぼんち１６さん
コロンの部屋 ポッチャリコロンさん
☆あいのマイペースブ… あいたろう３３さん
カエルのお池♪ カエル８２１さん
お気楽うさこの不思… keiko-0521-さん
けろころり keroko*さん
Comments
寺田屋の龍馬
@ Re[1]:龍馬のマイ・ベスト・クラシックス７１ No.1004 ～ フィリップ・ゴーベール「ファンタジー」／スーザン・ミラン(Fl)、イアン・ブラウン(Pf)(11/17)
俵のねずみさんへ ちゅ～吉殿お元気でし…
俵のねずみ
@ Re:龍馬のマイ・ベスト・クラシックス７１ No.1004 ～ フィリップ・ゴーベール「ファンタジー」／スーザン・ミラン(Fl)、イアン・ブラウン(Pf)(11/17)
来たよ来たよ来たよ～ よしよし復活（笑）…
寺田屋の龍馬
@ Re:龍馬のマイ・ベスト・クラシックス７１ No.1001 ～ リムスキー=コルサコフ 交響組曲「シェヘラザード」作品35・ボロディン 歌劇「イーゴリ公より『ダッタン人の踊り』」／アンセルメ、スイス・ロマンドほか（1960）(11/08)
ちゅ～吉殿お久しぶりであります…！ 今年…
2007/05/09
カテゴリ： MS Office／Excel VBA
☆エクセルのシート間で、セルのサイズ（セル範囲）に合わせて自由に画像の拡大・縮小コピーが行なえるＶＢＡプログラムほか。
「Hiro吉 Evoさん」より、記念すべき第１回のご質問を戴きましたので、次のとおり回答させて戴きます。
－ 質問１－
エクセルに「画像」を貼り付けているのですが、ＶＢＡでその画像をコピーしたり、枠に合わせて拡大、縮小したりできるのでしょうか？
－ 回答１－
例３のＶＢＡサンプルプログラムは、コピー元のシート名と画像No(名称)及びコピー先のシート名と貼付先のセル範囲を指定することで、貼り付けるセルのサイズに合わせて自由に画像の拡大･縮小コピーが行なえるというものです。
＊＊＊ サンプルプログラムの使い方 ＊＊＊
先ず、新規でエクセルを開き、ＶＢＡ編集画面から"ThisWorkbook"オブジェクトを開いて、例３の↓から↑までのプログラムリストをコピー＆ペーストで貼り付けます。
次に、"Sheet1"の画面に戻し、JPEG形式の名刺サイズ程度の画像を"Sheet1"の適当な場所へ貼り付けます。その際、画像No(名称)が「図 1」であることを確認して下さい。
最後に、マクロ名「ThisWorkbook.Sample_Prg」を実行すると、"Sheet2"の"C4:C5"のセル範囲に、"Sheet1"に貼り付けた画像が縮小コピーされているのが確認できます。
－ 質問２－
例えば、シートで商品台帳（写真付き）を作っていて、その商品（品番）を入力するだけで別のレイアウトの台帳に必要情報（写真含む）をコピーするとか…。
－ 回答２－
シート間のセルのコピーは、例１などの方法で行なえますので、例３のサブプログラム（Mov_Picture）と併せると、写真付商品台帳のシート間コピーが可能になり、さらに例２の商品番号などの検索メソッドと併せることで、ご質問の「その商品（品番）を入力するだけで別のレイアウトの台帳に必要情報（写真含む）をコピーする」ことが実現できるかと思います。
以上、小生の拙い説明でお分かり戴けたかどうか気になるところですが、ご不明の点やお気付きの点がございましたら、可能な限り対応させて戴きますので、いつでも何なりとお声がけ下さい。
この度はご質問を戴き、ありがとうございました。
例１：シート間のセルのコピー
Worksheets("Sheet2").Range("A11:C11").Value = _
Worksheets("Sheet1").Range("D22:F22").Value
例２：商品番号などの検索方法
'ShinNo = 検索する商品番号、LineNo = ヒットした行番号
Columns("A:A").Select 'Ａを検索
LineNo=Mid(Selection.Find(What:=ShinNo,After:=ActiveCell,LookIn:=xlValues, _
LookAt:=xlWhole,SearchOrder:=xlByRows,SearchDirection:=xlNext, _
MatchCase:=False).Address, 4)
注：検索に該当がない場合エラーで停止しますので、適宜エラー処理が必要です。
例３：シート間でセルのサイズに合わせて画像の拡大・縮小コピーを行う
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
Private Declare Function IsClipboardFormatAvailable _
Lib "user32.dll" _
(ByVal wFormat As Long) As Long
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Sub Sample_Prg()
Dim cSheet As String 'コピー元のシート名の定義
Dim cPicture As String 'コピー元の画像No(名称)の定義
Dim pSheet As String 'コピー先のシート名の定義
Dim pCell As String '貼付先のセル範囲の定義
'***************** サンプル変数値の設定 ******************
cSheet = "Sheet1" 'コピー元のシート名称
cPicture = "図 1" 'コピー元の画像No(名称)
pSheet = "Sheet2" 'コピー先のシート名称
pCell = "C4:C5" '貼付先のセルの範囲
'******************* 画像コピーの実行 ********************
Call Mov_Picture (cSheet, cPicture, pSheet, pCell)
End Sub
Sub Mov_Picture(cSheet As String, cPicture As String, _
pSheet As String, pCell As String)
'
' Sample Macro
' 作成日 : 2007/5/9 作成者名 : ロートルＰＧ
'
Dim MovCell As Range
Dim MovLeft As Double
Dim MovTop As Double
Dim MovHeight As Double
Dim MovWidth As Double
Set MovCell = Range(pCell)
'*********** コピー元のシートから画像をコピー ************
Sheets(cSheet).Shapes(cPicture).Select
Selection.Copy
'*********** 目的のシート(セル範囲)へ画像を貼付け ********
With MovCell
MovLeft = .Left
MovTop = .Top
MovHeight = .Cells(.Count).Offset(1).Top - .Top
MovWidth = .Cells(.Count).Offset(, 1).Left - .Left
End With
Sheets(pSheet).Pictures.Paste
With Sheets(pSheet).Pictures(Sheets(pSheet).Pictures. _
Count).ShapeRange
.LockAspectRatio = msoFalse
.Parent.Visible = msoTrue
.Left = MovLeft
.Top = MovTop
.Height = MovHeight
.Width = MovWidth
End With
End Sub
↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑
「Hiro吉 Evoさん」より、記念すべき第１回のご質問を戴きましたので、次のとおり回答させて戴きます。
－ 質問１－
エクセルに「画像」を貼り付けているのですが、ＶＢＡでその画像をコピーしたり、枠に合わせて拡大、縮小したりできるのでしょうか？
－ 回答１－
例３のＶＢＡサンプルプログラムは、コピー元のシート名と画像No(名称)及びコピー先のシート名と貼付先のセル範囲を指定することで、貼り付けるセルのサイズに合わせて自由に画像の拡大･縮小コピーが行なえるというものです。
＊＊＊ サンプルプログラムの使い方 ＊＊＊
先ず、新規でエクセルを開き、ＶＢＡ編集画面から"ThisWorkbook"オブジェクトを開いて、例３の↓から↑までのプログラムリストをコピー＆ペーストで貼り付けます。
次に、"Sheet1"の画面に戻し、JPEG形式の名刺サイズ程度の画像を"Sheet1"の適当な場所へ貼り付けます。その際、画像No(名称)が「図 1」であることを確認して下さい。
最後に、マクロ名「ThisWorkbook.Sample_Prg」を実行すると、"Sheet2"の"C4:C5"のセル範囲に、"Sheet1"に貼り付けた画像が縮小コピーされているのが確認できます。
－ 質問２－
例えば、シートで商品台帳（写真付き）を作っていて、その商品（品番）を入力するだけで別のレイアウトの台帳に必要情報（写真含む）をコピーするとか…。
－ 回答２－
シート間のセルのコピーは、例１などの方法で行なえますので、例３のサブプログラム（Mov_Picture）と併せると、写真付商品台帳のシート間コピーが可能になり、さらに例２の商品番号などの検索メソッドと併せることで、ご質問の「その商品（品番）を入力するだけで別のレイアウトの台帳に必要情報（写真含む）をコピーする」ことが実現できるかと思います。
以上、小生の拙い説明でお分かり戴けたかどうか気になるところですが、ご不明の点やお気付きの点がございましたら、可能な限り対応させて戴きますので、いつでも何なりとお声がけ下さい。
この度はご質問を戴き、ありがとうございました。
例１：シート間のセルのコピー
Worksheets("Sheet2").Range("A11:C11").Value = _
Worksheets("Sheet1").Range("D22:F22").Value
例２：商品番号などの検索方法
'ShinNo = 検索する商品番号、LineNo = ヒットした行番号
Columns("A:A").Select 'Ａを検索
LineNo=Mid(Selection.Find(What:=ShinNo,After:=ActiveCell,LookIn:=xlValues, _
LookAt:=xlWhole,SearchOrder:=xlByRows,SearchDirection:=xlNext, _
MatchCase:=False).Address, 4)
注：検索に該当がない場合エラーで停止しますので、適宜エラー処理が必要です。
例３：シート間でセルのサイズに合わせて画像の拡大・縮小コピーを行う
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
Private Declare Function IsClipboardFormatAvailable _
Lib "user32.dll" _
(ByVal wFormat As Long) As Long
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Sub Sample_Prg()
Dim cSheet As String 'コピー元のシート名の定義
Dim cPicture As String 'コピー元の画像No(名称)の定義
Dim pSheet As String 'コピー先のシート名の定義
Dim pCell As String '貼付先のセル範囲の定義
'***************** サンプル変数値の設定 ******************
cSheet = "Sheet1" 'コピー元のシート名称
cPicture = "図 1" 'コピー元の画像No(名称)
pSheet = "Sheet2" 'コピー先のシート名称
pCell = "C4:C5" '貼付先のセルの範囲
'******************* 画像コピーの実行 ********************
Call Mov_Picture (cSheet, cPicture, pSheet, pCell)
End Sub
Sub Mov_Picture(cSheet As String, cPicture As String, _
pSheet As String, pCell As String)
'
' Sample Macro
' 作成日 : 2007/5/9 作成者名 : ロートルＰＧ
'
Dim MovCell As Range
Dim MovLeft As Double
Dim MovTop As Double
Dim MovHeight As Double
Dim MovWidth As Double
Set MovCell = Range(pCell)
'*********** コピー元のシートから画像をコピー ************
Sheets(cSheet).Shapes(cPicture).Select
Selection.Copy
'*********** 目的のシート(セル範囲)へ画像を貼付け ********
With MovCell
MovLeft = .Left
MovTop = .Top
MovHeight = .Cells(.Count).Offset(1).Top - .Top
MovWidth = .Cells(.Count).Offset(, 1).Left - .Left
End With
Sheets(pSheet).Pictures.Paste
With Sheets(pSheet).Pictures(Sheets(pSheet).Pictures. _
Count).ShapeRange
.LockAspectRatio = msoFalse
.Parent.Visible = msoTrue
.Left = MovLeft
.Top = MovTop
.Height = MovHeight
.Width = MovWidth
End With
End Sub
↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑
お気に入りの記事を「いいね！」で応援しよう
[MS Office／Excel VBA] カテゴリの最新記事
-
☆エクセルのシートへ画像ファイルを挿入し… 2015/06/06
-
☆古いパソコンでも100万件のデータが容易… 2010/02/18
-
☆古いパソコンでも100万件のデータが容易… 2010/01/06 コメント(4)
【毎日開催】
15記事にいいね！で1ポイント
© Rakuten Group, Inc.
