excel2000を利用しています。
下記のとあるプロシージャで自分で修正を試みるもどうしても出来ず投稿させていただきました。
どうか修正内容のアドバイスをお願いします。
■やろうとしていること
下記は写真を表示させる部分のコードです。下記 「worksheetchange」 イベントプロシージャで、レコードが変わると下記「myLoadPicture」が発生し、写真を表示させて、レコードを切り替えるたびに、その写真を切り替えるというものです。
■相談したいこと
いま指定したセルが空白だと、"NoImage.jpg"が表示されるようになっていますが、指定したフォルダに一致するファイルがなかった場合も、"NoImage.jpg"が表示されるようにしたいのですが、修正方法がわかりません。
どうかご教授お願いいたします。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRange As Range
Dim touroku As Long
Select Case Target.Address
Case "$BC$1"
Call hyouji
Case "$BW$1"
myLoadPicture "board_Image", Target.Text, Range("BH3")
Case "$CY$1"
myLoadPicture "circuit_Image", Target.Text, Range("CJ3")
Case Else
Exit Sub
End Select
End Sub
Private Sub myLoadPicture(folderName As String, fname As String, targetRange As Range)
On Error Resume Next
Dim pict As Shape, picPath As String
picPath = ThisWorkbook.Path & "\" & folderName & "\" & fname
If fname = "" Then
picPath = ThisWorkbook.Path & "\" & folderName & "\" & "NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = targetRange.Address Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(picPath, msoTrue, msoFalse, _
targetRange.Left, targetRange.Top, 260, 320)
End With
Exit Sub
End Sub
こんにちは。vba初心者です。
セルのA１を参照してシート名を変更するとき
名前が重複したら、A1に入力されている文字列の後に（2）とつけたいのですが、
その重複したときの処理ができません。
シート名を変更するところまではできました。
以下のvbaです。
Sub test()
Dim aSheet As Worksheet
For Each aSheet In Worksheets
aSheet．Select
aSheet．Name = Range("A1")
On Error Resume Next
Next aSheet
End Sub
これに付け加えるか全然違ってもかまいません。
何かよい方法を教えてください。
説明が不十分かもしれませんが、よろしくお願いします。
データ入力シート「Hit Data]
データ表示シート「User Sheet」
とあります。
データ表示シート「User Sheet」に「次へ」「前へ」「最初へ」「最後へ」とボタンをつくり、データ入力シート「Hit Data]から、都度データを呼び出せるようにするプログラムをとあるサイトを参考にして作成しましたが、エラーが出てしまいどうしてもうまくいきません。
どこに問題があるのか見ていただけないでしょうか？
'以下標準モジュールのプログラムです
Public trg As Range
Sub Saisyo()
Set trg = Worksheets("Hit Data").Range("A3")
Call Tenki
End Sub
Sub Saigo()
Set trg = Worksheets("Hit Data").Range("A60000").End(xlUp)
Call Tenki
End Sub
Sub Mae()
If trg.Row >= 4 Then
Set trg = trg.Offset(-1, 0)
Call Tenki
Else
MsgBox "これより前のレコードはありません"
End If
End Sub
Sub Tsugi()
If trg.Row < Worksheets("Hit Data").Range("A60000").End(xlUp).Row Then
Set trg = trg.Offset(1, 0)
Call Tenki
Else
MsgBox "これより後ろのレコードはありません"
End If
End Sub
Sub Tenki()
Worksheets("User Sheet").Range("D9").Value = trg.Offset(0, 0)
Worksheets("User Sheet").Range("D10").Value = trg.Offset(0, 1)
Worksheets("User Sheet").Range("D11").Value = trg.Offset(0, 2)
Worksheets("User Sheet").Range("D12").Value = trg.Offset(0, 3)
End Sub
'以下 User Sheet"のシートモジュールに記載されたプログラムです。
Private Sub Worksheet_Activate()
Call Saisyo
End Sub
'表示されるエラーの内容
'saisyo・・・アプリケーション定義またはオブジェクト定義のエラーです。
'saigo・・・同上
'mae・・・オブジェクト変数またはWithブロック変数が設定されていません
'tugi・・・同上
データ入力シート「Hit Data]
データ表示シート「User Sheet」
とあります。
データ表示シート「User Sheet」に「次へ」「前へ」「最初へ」「最後へ」とボタンをつくり、データ入力シート「Hit Data]から、都度データを呼び出せるようにするプログラムをとあるサイトを参考にして作成しましたが、エラーが出てしまいどうしてもうまくいきません。
どこに問題があるのか見ていただけないでしょうか？
'以下標準モジュールのプログラムです
Public trg As Range
Sub Saisyo()
Set trg = Worksheets("Hit Data").Range("A3")
Call Tenki
End Sub
Sub Saigo()
Set trg = Worksheets("Hit Data").Range("A60000").End(xlUp)
Call Tenki
End Sub
Sub Mae()
If trg.Row >= 4 Then
Set trg = trg.Offset(-1, 0)
Call Tenki
Else
MsgBox "これより前のレコードはありません"
End If
End Sub
Sub Tsugi()
If trg.Row < Worksheets("Hit Data").Range("A60000").End(xlUp).Row Then
Set trg = trg.Offset(1, 0)
Call Tenki
Else
MsgBox "これより後ろのレコードはありません"
End If
End Sub
Sub Tenki()
Worksheets("User Sheet").Range("D9").Value = trg.Offset(0, 0)
Worksheets("User Sheet").Range("D10").Value = trg.Offset(0, 1)
Worksheets("User Sheet").Range("D11").Value = trg.Offset(0, 2)
Worksheets("User Sheet").Range("D12").Value = trg.Offset(0, 3)
End Sub
'以下 User Sheet"のシートモジュールに記載されたプログラムです。
Private Sub Worksheet_Activate()
Call Saisyo
End Sub
'表示されるエラーの内容
'saisyo・・・アプリケーション定義またはオブジェクト定義のエラーです。
'saigo・・・同上
'mae・・・オブジェクト変数またはWithブロック変数が設定されていません
'tugi・・・同上
すいません、前回質問した者です。
前回の質問では・・・
エクセルシートのB列にURLが並んでいるとして、ＶＢＡを使って、C列には「description」D列には「keywords」を抽出したいという質問をしたのですが、参考になる回答がなかったのでもう一度質問します。
以前、私が教えてもらったのは、B列にURLが並んでいて、Ａ列にタイトルを抽出させたものでした。
それが以下になります。
Public Sub ReadTitle()
Dim url As Range
Dim Http, buf As String
Set Http = CreateObject("MSXML2.XMLHTTP")
Set url = Range("B1")
Do While (url.Value <> "")
Http.Open "GET", url.Value, False
Http.Send
buf = StrConv(Http.ResponseBody, vbUnicode)
'msgbox buf
url.Offset(0, -1).Value = getTitle(buf)
Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
End Sub
Private Function getTitle(buf As String) As String
Dim pos1 As Long, pos2 As Long
pos1 = InStr(1, buf, "<title>")
If pos1 = 0 Then
pos1 = InStr(1, buf, "<TITLE>")
If pos1 = 0 Then
getTitle = ""
Exit Function
Else
pos2 = InStr(pos1 + 7, buf, "</TITLE>")
End If
Else
pos2 = InStr(pos1 + 7, buf, "</title>")
End If
getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7)
End Function
このような感じでＢ列にはURLの一覧があるとして、Ａ列にタイトル、C列にdescription D列にkeywordsが抽出できればいいなと考えています。
ちなみに、私にはＶＢＡの知識がまったくありません。とりあず、これだけ出来れば、すごく助かるのですが、どなたか教えていただけないでしょうか？
よろしくお願いします！
「7を超えたら、For Eachステートメントを抜けなさい」という条件を入れたいのですが、
7を超えても処理が継続し困っています。
勉強不足で申し訳ないですが、ご教授願います。
【やりたいこと】
まず、セルB1～D3までのセルの値（9つ）が、7を超えない条件で1を加算していきます。
加算したときの値はE～Gの列に貼り付けていきます。
7を超えた時点でFor Eachステートメントを抜けます。
また、B1～D3までのセルには計算式が入っており、A1に数字を入れると、
それぞれ異なる増え方をします。（計算式自体は$A$1+1.1、$A$1+2.1などシンプルなもの）
Sub test()
Dim i As Range
Dim n As Long
Dim x As Long
n = 1
x = 1
For Each i In Range("B1:D3")
Range("A1").Value = x
If i < 7 Then
Range("B1:D3").Copy
Cells(n, 5).Select
Selection.PasteSpecial Paste:=xlPasteValues
n = n + 3
x = x + 1
ElseIf i > 7 Then
Exit For
End If
Next
End Sub
お手数ですが、宜しくお願いいたします。
下記コードで具体的アドバイスを頂ければと思います。よろしくお願いいたします。
■やりたいこと
EXCELのシートに、２種類の写真表示スペースを作って、そのそばでそれぞれファイル名を入力して、そのファイル名を変えるごとに、それぞれのjpegファイルを表示させたい。
■質問
下記コードで、ふたつめの変数を変えればよいことは、分かるのですが、どこをどのようにして、変数を変えればいいかわかりません。ご教授お願いします。
■私の作っているコード
とあるサイトを参考にして、下記作成いたしました。
'ひとつめ写真表示
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
If Target.Address <> "$H$25" Then Exit Sub
fName = ThisWorkbook.Path & "\board_Image\" & Target.Offset(0, 0).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\board_Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$C$26" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("k6").Left, .Range("C26").Top, 260, 320)
End With
End Sub
-----------------------------------------------------------------------------
'ふたつめ写真表示
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fName As String, pict As Shape
If Target.Address <> "$AT$4" Then Exit Sub
fName = ThisWorkbook.Path & "\map_Image\" & Target.Offset(0, 0).Text
If Dir(fName) = "" Then
fName = ThisWorkbook.Path & "\map_Image\NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = "$k$6" Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
.Range("k6").Left, .Range("k6").Top, 260, 320)
End With
End Sub
