- 締切済み
エクセル2010のvbaについて
Sub abc() Dim a Set a = Selection If a.Width * 4 / 3 <> 90 And a.Height * 4 / 3 - 1 <> 120 Then MsgBox ("120x90px以外の画像以外は挿入できません") End If End Sub 上のコードを実行するとなぜか120×90以外でも メッセージが表示されなくなります （Msgbox a.Width * 4 / 3は90 Msgbox a.Height * 4 / 3は120と正しく表示されます） 更に高さが1px多くなってしまいます（-1） （高さを調べても121pxではなく120pxでした） たまにvbaをしている時にあるので 回答と原因もお願いします
- atamanotaisou1
- お礼率32% (14/43)
- その他MS Office製品
- 回答数2
- ありがとう数2
- みんなの回答 （2）
- 専門家の回答
みんなの回答
- WindFaller
- ベストアンサー率57% (465/803)
- keithin
- ベストアンサー率66% (5278/7940)
まず ＞MsgBox ("120x90px以外の画像以外は挿入できません") を実現したいなら、andではなく If a.Width * 4 / 3 <> 90 or a.Height * 4 / 3 <> 120 Then ですね。 Ａｎｄじゃ、片方の寸法が合ってたらメッセージは立ちません。 また、 ＞高さを調べても121pxではなく120pxでした と、高さが120pxと判っているのに ＞高さが1px多くなってしまいます とは、一体どういうことでしょうか。 先のＡＮＤとＯＲの間違いだったのならそれはそれでですが、そうじゃないならもうちょっと詳しく状況を添えて新しいご相談として投稿し直してみて下さい。
お礼
有難う御座いました AndとOrが違うのは勉強になりました >＞高さが1px多くなってしまいます 原因は前のマクロでした （前のマクロにaが代入されたままこのマクロが実行されたのが原因でした）
関連するQ&A
- エクセル２００７のVBAの困りごと
教えてください。 画像挿入時にエクセルのセルの大きさに合わせるマクロを使っているのですが、エクセル２０００、２００３では問題なく動くのですが、２００７だと、うまくVBAが動かず、画像が縮小・拡大されません。 わかるかた教えてください。 コード Dim c As Range, cm As Range Application.ScreenUpdating = False For Each c In Selection Set cm = c.MergeArea If c.Address = cm.Item(1).Address Then If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub With Selection .Left = cm.Left .Top = cm.Top .Height = cm.Height .Width = cm.Width End With End If Next Set cm = Nothing
- 締切済み
- オフィス系ソフト
- エクセルのマクロで画像を貼り付け
画像をエクセルに貼り付ける作業を行っています。 マクロを使いファイル内の画像（約３０枚程度）を１列づつスペースを空け 右方向に４枚 １行スペースを空け ３行目の左に戻り その位置よりまた１列づつスペースを空け右方向に４枚・・・・・ これを繰り返しファイル内の画像をすべて 貼り付けたいのですがうまく動作が出来ません。 何卒ご教授の程よろしくお願いします。 ※マクロ Sub EggFunc_pasteDirImage() ' 変数定義 Dim fileName As String Dim targetCol As Integer Dim targetRow As Integer Dim targetCell As Range Dim shell, myPath Dim pos As Integer Dim extention As String Dim isImage As Boolean ' 選択セルを取得 targetCol = ActiveCell.Column targetRow = ActiveCell.Row ' フォルダ選択画面を表示 Set shell = CreateObject("Shell.Application") Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\0602116.MS\Desktop\") Set shell = Nothing ' フォルダを選択したら... If Not myPath Is Nothing Then fileName = Dir(myPath.Items.Item.Path + "\") Do While fileName <> "" ' ファイル拡張子の判別 isImage = True pos = InStrRev(fileName, ".") If pos > 0 Then Select Case LCase(Mid(fileName, pos + 1)) Case "jpeg" Case "jpg" Case "gif" Case Else isImage = False End Select Else isImage = False End If ' 拡張子が画像であれば If isImage = True Then ' 貼り付け先を選択 Cells(targetRow, targetCol).Select Set targetCell = ActiveCell ' 画像読込み ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select ' 画像が大きい場合、画像サイズをセル幅に合わせる If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then Selection.Height = Selection.Height * (targetCell.Width / Selection.Width) Selection.Width = targetCell.Width Else Selection.Width = Selection.Width * (targetCell.Height / Selection.Height) Selection.Height = targetCell.Height End If End If ' 表示位置をセル中央に移動 Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2 Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2 ' 貼り付け先行を+1 targetCol = targetCol + 2 End If fileName = Dir() Loop MsgBox "画像の読込みが終了しました" End If End Sub
- ベストアンサー
- Visual Basic
- EXEL VBAで印刷の指定をしたいのですが
VBA初心者、勉強中です。 sheet1に２つの表がありまして下記のとおりボタンをクリックしたらインプットボックスが立ち上がって２つの表の１か２を指定したら範囲がぷれびゅーするということなんですが、１を入れても、２を入れてもMsgBox "1か2を入力して！しか表示しません。 さんざん調べまくりましたが、どなたかご教授お願いします。 Sub 印刷() Dim SentP As Integer On Error Resume Next SentS = InputBox("どちらを印刷？1売上 2材料") If SentP = 1 Then Range("a1:g32").Select Selection.printpreiew ElseIf SentP = 2 Then Range("j1:n41").Select Selection.PrintPreview Else MsgBox "1か2を入力して！" End If End Sub
- ベストアンサー
- その他MS Office製品
- Excel VBAを簡素化したいのですが動きません
お世話になります。VBA初心者です。 下記TESTは動くのですが、『If myINT= Then』が永遠に続くので簡素化したく 『Rows("myINT : myINT").Select』これを入れてみたのですが全く動きません。 簡素化した記述を教えて下さい。宜しくお願い致します。 Sub TEST() Dim myINT As Integer myINT = ActiveSheet.Cells.SpecialCells(xlLastCell).Row If myINT = 1 Then Rows("1:1").Select ElseIf myINT = 2 Then Rows("2:2").Select ElseIf myINT = 3 Then Rows("3:3").Select Else MsgBox "TEST" End If End Sub
- ベストアンサー
- その他(業務ソフトウェア)
- エクセルに写真を挿入するVBA
エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか？ よろしくお願いいたします。 やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim PicFile As Variant Dim rX As Double, rY As Double '［ファイルを開く］ダイアログボックスを表示 PicFile = Application.GetOpenFilename( _ "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp") If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub Application.ScreenUpdating = False '画像を挿入 With ActiveSheet.Pictures.Insert(PicFile) rX = Target.Width / .Width rY = Target.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If 'セルの中央（横方向/縦方向の中央）に配置 .Left = Target.Left + (Target.Width - .Width) / 2 .Top = Target.Top + (Target.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub
- 締切済み
- その他MS Office製品
- Excel VBA ループについて
Excel VBA勉強中の者です。 シート名「一覧」のA列に入力されている「1」を検索し、メッセージボックスに表示させています。 現在、「1」はA3、A5、A7に入力されています。 下記のコードだとA3、A5、A7がメッセージボックスで表示された後、もう一度A3が表示されてしまいます。 A7が表示された時点で終わりにしたいのですが、どこを修正すればいいのでしょうか？ Sub test() Dim xRange As Range Dim fPlace As String Dim i As Integer Dim xMoji As String xMoji = 1 Set xRange = Worksheets("一覧").Range("A1:A100").Find(What:=xMoji) If Not xRange Is Nothing Then fPlace = xRange.Address Msgbox xRange.Address Do Set xRange = Worksheets("一覧").Range("A1:A100").FindNext(After:=xRange) If Not xRange Is Nothing Then Msgbox xRange.Address End If Loop Until fPlace = xRange.Address End If End Sub よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- EXCEL VBA これであっていますか？
エクセルに地図を貼り付け、その中のある地点Aから半径１キロ、２キロ、３キロといった具合に円を描いています。ある地点B、Cも同様に円があります。セルに“A” と入力した際に該当する地点の円（１キロ、２キロ、３キロの3種類）を赤く表示し、終了すると円が消える（線なしに変わる）ようにするために以下のようなＶＢＡを組みました。が、円が２つしか赤くならなかったり、 ばあいによっては「インデックスが境界を超えています」とエラーが出たりします。 どうしたら良いか教えてください。 Sub iro() Dim i As Variant i = InputBox("表示する地点を指定してください", "地点指定") If i = "A" Then ActiveSheet.Shapes(1).Select ActiveSheet.Shapes(2).Select ActiveSheet.Shapes(3).Select Replace:=False hyoji MsgBox "表示を終了してよろしいですか", vbOKOnly ActiveSheet.Shapes(1).Select ActiveSheet.Shapes(2).Select ActiveSheet.Shapes(3).Select Replace:=False modosu ElseIf i = "B" Then ActiveSheet.Shapes(4).Select ActiveSheet.Shapes(5).Select ActiveSheet.Shapes(6).Select Replace:=False hyoji MsgBox "表示を終了してよろしいですか", vbOKOnly ActiveSheet.Shapes(4).Select ActiveSheet.Shapes(5).Select ActiveSheet.Shapes(6).Select Replace:=False Else MsgBox "指定した地点がありません", vbOKOnly End If End Sub Sub hyoji() Selection.ShapeRange.Line.Visible = msoTrue '「線なし」に設定されている場合、線を表示 Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 Range("A1").Select End Sub Sub modosu() Selection.ShapeRange.Line.Visible = msoFalse '「線なし」に設定 Range("A1").Select End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでお願いします。
エクセル２００２使用です。 セルA1に 日付型で2004/9/25と間違いなく入っています。 その条件で下記のようにコードを打ちました。 Sub test() If Day(Range("A1")) = 30 Then MsgBox "yes" End If End Sub 25=30ならばmsgboxを表示なので、上記の例では表示してはいけないのに表示されます。 ちなみに＝を＜＞不等号にしてもMsgboxが開きます。 おそらく型の問題だと思ったのですが、DAY関数はVariant型のintergerなので問題ないと思うのですが、理由がわかりません。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBA 重複を表示したい
エクセルVBA 重複を表示したい Ａ列で重複すると警告するコードを以下のように作成しました。 これを修正してＡ列で重複して、なおかつＢ列でも重複した場合警告するコードにしたいのです。 添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。 ご教授よろしくお願いします。 Sub test() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String For Each myRange In Range("A2:A10") If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub
- ベストアンサー
- その他MS Office製品
- VBA
選択したセルから複数画像を貼付け、画像の右セルに画像名を記入したいのですが、 画像名の記入方法がわからず、うまく動作できません。 ご教授の程、宜しくお願い致します。 例)A1セルを選択マクロ実行、画像3枚を貼付けたい：A1～A3セルに画像貼付け、B1～B3セルに画像名記入 ※※※※※※※※※※マクロ※※※※※※※※※※ Sub 画像貼付け() Dim i As Long, j As Long, k As Long Dim FileName As Variant Dim dblscal As Double Dim sp As Shape FileName = Application.GetOpenFilename( _ filefilter:="画像ファイル,*.jpeg;*.jpg;*.gif;*.JPG", _ MultiSelect:=True) Dim inp As Range On Error Resume Next Set inp = Application.InputBox( _ prompt:="マウスで開始セルを選択してください", _ Title:="開始セルを選択", _ Default:="マウスで開始セルを選択する", _ Type:=8) ''←メッセージボックスで開始セルを選択させる If Err.Number = 0 Then MsgBox mayrange.Address Else MsgBox "キャンセルしました。" End If j = inp.Row ''←選択した開始セルの行 k = inp.Column ''←選択した開始セルの列 For i = LBound(FileName) To UBound(FileName) Cells(j, k).Select With ActiveSheet.Shapes.AddPicture( _ FileName:=FileName(i), _ linktofile:=False, _ savewithdocument:=True, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) .ScaleHeight 1, msoTrue .ScaleWidth 1, msoTrue If Cells(j, k).Width / .Width < Cells(j, k).Height / .Height Then dblscal = WorksheetFunction.RoundDown(Cells(j, k).Width / .Width, 2) Else dblscal = WorksheetFunction.RoundDown(Cells(j, k).Height / .Height, 2) End If .Width = .Width * dblscal * 0.97 .Height = .Height * dblscal * 0.97 .Left = .Left + (Cells(j, k).Width - .Width) / 2 .Top = .Top + (Cells(j, k).Height - .Height) / 2 End With k = k + 0 j = j + 1 Next i End Sub
- ベストアンサー
- Visual Basic
- 給与明細の固定項目の追加は可能なのか、無料版には同じ方法が使えないのかについてご質問いただきました。
- 無料版では給与明細の固定項目の追加はできないのでしょうか。有料版と同じ方法で追加することはできるのでしょうか。
- 無料版での給与明細の固定項目の追加方法についてお詳しい方がいらっしゃいましたら、教えていただけると幸いです。
お礼
有難う御座いました pixelではなくpointで計算するのは意外でした >VBA上で、小数点計算で、そんなにピッタリと行くとは思えないのです。 原因は前のマクロでした （前のマクロにaが代入されたままこのマクロが実行されたのが原因でした）