- 締切済み
サンプルプログラムでエラーが出てしまいます、対処法を教えて下さい。
Sub test写真の連続挿入() Dim myDir As String Dim myFile As String Dim i As Integer Dim n As Integer n = 10 myDir = "D:\写真\" myFile = Dir(myDir, vbNormal) Application.ScreenUpdating = False Do Until myFile = "" If myFile <> "." And myFile <> ".." Then If (GetAttr(myDir & myFile) And 16) <> 16 Then i = i + 1 With ActiveSheet.OLEObjects("Image" & i) .Object.PictureSizeMode = 3 .Object.Picture = LoadPicture(myDir &myFile) End With If i = n Then Exit Do End If End If myFile = Dir Loop Application.ScreenUpdating = True End Sub このWith ActiveSheet.OLEObjects("Image" & i)の行でエラーが出てしまいます、対処法を教えて下さい。（ 実行時エラー'1004'OLEObjects プロパティを取得できません）
- yosio3198
- お礼率82% (19/23)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- watabe007
- ベストアンサー率62% (476/760)
アクティブシート上のイメージコントロールに写真を貼り付ける様になっているので 写真の数だけイメージコントロールが必要です。 [表示]-[ツールバー]-[コントロールツールボックス]-[イメージ]
関連するQ&A
- エクセルにフォルダにある画像を貼付&整列する方法
下記にあるマクロより、 選択したフォルダ内の画像ファイル（jpgファイル）すべてをA列に挿入、 B列にA列のファイル名の書き込みは出来ましたが、、、 この画像ファイルをファイル名ごとに整列する方法をお教え願います。 目的は、画像を横に並べ写真を比較したいです。 （例） 頭に「1」が付くファイル名・・・A列 頭に「2」が付くファイル名・・・C列 頭に「3」が付くファイル名・・・E列 よろしくお願いします。 （マクロ） Sub InsertPictures() Dim i As Integer Dim myDir As String Const myHeight = 200 '行の高さ。0-409を指定。写真のサイズがこれで調整される。 Const myWidth = 50 '列の幅。0 - 255を指定。 Dim myFName As String myDir = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg") If myDir = "False" Then Exit Sub myDir = Left(myDir, Len(myDir) - Len(Dir(myDir))) Application.ScreenUpdating = False ActiveSheet.DrawingObjects.Delete Columns(2).ClearContents Rows.AutoFit i = 1 myFName = Dir(myDir & "*.jpg") Do While myFName <> "" With Cells(i, 1) .Activate .RowHeight = myHeight End With With ActiveSheet .Pictures.Insert myDir & myFName With .Shapes(i) .LockAspectRatio = msoTrue .Height = myHeight End With End With Cells(i, 2).Value = myFName myFName = Dir i = i + 1 Loop Columns(1).ColumnWidth = myWidth Columns(2).AutoFit Application.ScreenUpdating = True End Sub
- 締切済み
- オフィス系ソフト
- ExcelのAutoFilter への変数の使用がうまく行きません！
ExcelのAutoFilter への変数の使用がうまく行きません！ Windows XP Home Edition SP3 Office XP Personal 2002 Excel 2002 下記の NNN に 「 InputBox に 入力した整数 」 を変数で使用したいのですが、 どのようにすればよろしいでしょうか？ 何卒、ご教示のほどをお願い致します。 Sub TEST1() Dim NNN As Integer Dim msg As String Dim i As Integer Application.ScreenUpdating = False msg = "【整数】 を入力してください。" NNN = InputBox(msg) If ActiveSheet.AutoFilterMode Then With ActiveSheet.AutoFilter For i = 88 To 90 .Range.Rows(1).Cells(i).AutoFilter Field:=i, Criteria1:="<=NNN" '←この NNN です Next i End With End If Application.ScreenUpdating = True End Sub
- ベストアンサー
- オフィス系ソフト
- Excelの既存シートへの写真自動貼付け
With ActiveSheet.OLEObjects("Image" & i) .Object.PictureSizeMode = 3 .Object.Picture = LoadPicture(myDir & myFile） ・・・のようなimage等を使わず、単純に貼りつけるだけのプログラムを教えて下さい。 具体的にはエクセルの挿入で貼りつけた図１～n の写真を得ることです。
- 締切済み
- Visual Basic
- 写真をリンクではなく挿入する
リンク元の写真を削除して開くと 「元のリンクされたイメージを表示できません・・・・」と、なります。 ならないようにするための、挿入方法を教えてください。 拙策な質問ですが、よろしくお願いします。 Application.ScreenUpdating = False Dim EndRow As Long Dim j As Integer Dim shp As Shape Dim myFolder As String, myFile As String For Each shp In ActiveSheet.Shapes EndRow = Application.Max(EndRow, shp.BottomRightCell.Row) Next Worksheets("施工写真【T】").Cells((EndRow) + 3, 3).Activate With Application.FileDialog(msoFileDialogFolderPicker) .Title = "*** 対象フォルダを選択し、[OK]をクリック ***" .InitialFileName = "D:\" If .Show = True Then myFolder = .SelectedItems(1) myFile = Dir(myFolder & "\*.jpg") Do While myFile <> "" ActiveSheet.Pictures.Insert(myFolder & "\" & myFile).Select With Selection .Top = ActiveCell.Top .Left = ActiveCell.Left .Width = ActiveCell.Width * 14 .Height = ActiveCell.Height * 8 End With ActiveCell.Offset(11, 0).Activate myFile = Dir() Loop Else Exit Sub End If End With 写真整理.写真NO.Value = ((EndRow) / 11) Worksheets("施工写真【T】").Cells(1, 1).Value = 1 For j = 11 To EndRow Step 11 Worksheets("施工写真【T】").Cells(j, 1).Value = Cells(j - 11, 1) + 1 Next j ActiveCell.Offset(0, 0).Activate Unload Me 写真整理.Show vbModeless Application.ScreenUpdating = True
- ベストアンサー
- Excel（エクセル）
- VBA実行時のエラー
下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。 このプログラムをシートから実行した所 エラー：400『既にフォームは表示されています。モーダルにできません。』 なるものが表示されてしまいます。 またコードを記述する所から実行しますと 実行時エラー：１００４『アプリケーション定義またはオブジェクト定義のエラー』 となってしまいます。 私の努力が足りないのは重々承知ですが、解決する事が出来ません。 皆様のお力を借りることが出来たらと思い投稿しました。 宜しくお願い致します。 Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "dem******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = Fales .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set WS1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destinaton:=Range("A1:A512") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = trFILENAME & "処理中..." Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 255 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 255 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 255 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 WS1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub
- ベストアンサー
- オフィス系ソフト
- 一部マクロを変更したいので教えてください。
現在、下記のようなマクロを使用しています。 Sub sample() Dim myFile As String, myPath As String, i As Long Application.ScreenUpdating = False myPath = InputBox("フルパスでフォルダーを指定") myFile = Dir(myPath & "\*.xls", vbNormal) Do Workbooks.Open myPath & "\" & myFile For i = 1 To ActiveWorkbook.Sheets.Count If WorksheetFunction.CountA(Sheets(i).Range("B7:B11")) = 0 Then Sheets(i).Range("B7") = "*" End If Next ActiveWorkbook.Close True myFile = Dir() Loop While myFile <> "" Application.ScreenUpdating = True MsgBox "完了 ！！" End Sub 上から４行目のmyPath = InputBox("フルパスでフォルダーを指定")を パスを入力するマクロではなくてもっと簡単にフォルダを選択するマクロに変更したいのですが どうすればいいですか？
- ベストアンサー
- オフィス系ソフト
- マクロを使用してCSVファイルの結合を行いたい
過去の質問の中から、素晴らしい結合のマクロを見つけましたが、パソコンをwindows7にエクセルを エクセル2010に変更した後、マクロが使えなくなりました。 どなたか修正して頂けないでしょうか？ 列の項目は定形で、10～200行のデータが書かれたCSVファイルが1つのフォルダに多数あります。 新しいファイルに、NO.1のファイルのデータの続きにNO.2、NO.3・・・と続けてデータが下の行に連続 して並ぶようにマクロで結合させたいと思っていますので、宜しくお願いします。 Sub Test1() Dim files As FileSearch, FilesCnt As Integer, i As Integer Dim cBook As Workbook, pBook As Workbook FilesCnt = mySearch(files, ThisWorkbook.Path) If FilesCnt = 0 Then Exit Sub Set pBook = Workbooks.Add(xlWBATWorksheet) For i = 1 To FilesCnt Workbooks.Open files.FoundFiles(i) Set cBook = ActiveWorkbook cBook.ActiveSheet.UsedRange.Copy With pBook.ActiveSheet If i > 1 Then .Cells(.Range("A65536").End(xlUp).Row + 1, 1). _ PasteSpecial (xlPasteAll) Else .Cells(.Range("A65536").End(xlUp).Row, 1). _ PasteSpecial (xlPasteAll) End If End With Application.CutCopyMode = False cBook.Close Next i Set cBook = Nothing: Set pBook = Nothing End Sub '******************************************************************** Function mySearch(files As FileSearch, myDir As String) As Integer mySearch = 0 Set files = Application.FileSearch With files .NewSearch .LookIn = myDir .SearchSubFolders = True .Filename = "*.csv" If .Execute() > 0 Then mySearch = .FoundFiles.Count End With End Function
- ベストアンサー
- オフィス系ソフト
- 最大行数を取得するVBAコードとは？
人生で初めてエクセルのマクロに挑戦してみた。が、《最大行数を取得するVBAコード》で躓いた。２時間ばかり、悪戦苦闘したがサッパリ判らない。苦肉の策で、SQL文を使った。でも、それじゃー解決したことにはならない。 Public Sub Do_XferPer() Dim I As Integer Dim N As Integer Application.ScreenUpdating = False ' ' 先頭行の取得 ' N = DLookup("SELECT COUNT(*) FROM [Sheet3$A:A1000]") - 1 Debug.Print N For I = 2 To N If 0 Then Cells(I, 1) = XferPer(Cells(I, 1)) End If Next I Application.ScreenUpdating = True With ThisWorkbook.Worksheets("Sheet3").UsedRange N = .Rows.Count - 1 Debug.Print N End With With Range("A1").SpecialCells(xlLastCell) N = .Row - 1 Debug.Print N End With End Sub 【質問】 みなさんは、最大行数を取得するのにどのようなコードを書かれていますか？ 宜しくお願いします。
- ベストアンサー
- Excel（エクセル）
- 複数のエクセルファイルとシートからデータ抽出したい
以前に http://soudan1.biglobe.ne.jp/qa8369459.html でやられている内容なのですが、私の場合はシートすべての[i4」のセル値を一覧でひっぱりたいです。 keithinさんご回答の sub macro1() dim myPath as string dim myFile as string dim w as worksheet mypath = thisworkbook.path & "\" myfile = dir(mypath & "*.xls*") application.screenupdating = false do until myfile = "" if myfile <> thisworkbook.name then workbooks.open mypath & myfile for each w in workbooks(myfile).worksheets with thisworkbook.worksheets("Sheet1").range("A65536").end(xlup).offset(1) .value = myfile .offset(0, 1) = w.name .offset(0, 2).value = w.cells(w.rows.count, "C").end(xlup).value ↑をRange("i4").Value end with next workbooks(myfile).close false end if myfile = dir() loop application.screenupdating = true end sub にて実施しましたが、ファイル名・シート名は正確に抽出するものの 参照したい「i4」のデータが先頭のシートのi4だけを拾ってしまいます １．ｘｌｓ、２．ｘｌｓ、３ｘｌｓがありそれぞれ名前がばらばらなシート「あ」、「い」、「う」の3つがある。２．ｘｌｓには「え」、「お」、「か」のしーとがあると仮定、マクロを実行すると、一覧のエクセルに １、ｘｌｓ あ あのシートi4の値 １、ｘｌｓ い あのシートi4の値 １、ｘｌｓ う あのシートi4の値 ２．ｘｌｓ え えのシートi4の値 ２．ｘｌｓ お えのシートi4の値 ２．ｘｌｓ か えのシートi4の値 子のようなか形で出力されます い のところには いのシートのi4が、う のところには うのシートのi4が、 抽出されるには構文をどう買えればよいのでしょうか
- ベストアンサー
- Visual Basic
- やはり図形のクリアで実行時エラー1004
図形を二行三列で一枡とし図形を貼り付けていますが、どうしても実行時エラー 「1004」が出て図形のクリアができません。(尚、四角形は枠線上にあります。) 対処法がありましたらお願いします。 Windows7・SP1 Office2010 Sub 図形の貼付け() Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 9 To 99 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Cells(i + 1, j).Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 5: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 2).Select ActiveSheet.Paste Case 6: ActiveSheet.Shapes("円1").Select Selection.Copy Cells(i, j).Select ActiveSheet.Paste End Select Next Next End Select End Sub Sub 図形のクリア() Dim myRng As Range Set myRng = Range("I10:CW43") Dim n As Integer, sp As Variant For n = ActiveSheet.Shapes.Count To 1 Step -1 Set sp = ActiveSheet.Shapes(n) If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing (ここで実行時エラー1004になります。) Then sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
お礼
ありがとうございました。
補足
元のプログラムのIf (GetAttr(myDir & myFile) And 16) <> 16 Then・・・の行の１６、１６はなにを意味するのでしょうか。低レベルの質問ですが教えて下さい。