【復活求む!】惜しくも解散してしまったバンド|J-ROCK編 >>

https://bgp.he.net/AS9228
のURLからtitleタグを取ってきて、文字列分割して、一部の文字を画面に表示するVBスクリプトを作成しましたが、最後の行で添付のエラーが出ます。どなたかデバグ方法を教えてください!




------
Option Explicit

Dim objIE

Set objIE = CreateObject("InternetExplorer.Application")
'IEを開くかどうか。開くを指定
objIE.Visible = True

'当該ページをIEで開く
objIE.navigate "https://bgp.he.net/AS9228"


'ページが読み込まれるまで待つ
Do While objIE.Busy = True Or objIE.readyState <> 4
WScript.Sleep 100
Loop


'タイトルを表示
msgbox objIE.document.Title


Dim s As String
Dim s1 As String
Dim p As String
Dim result as String

'タイトルタグを変数に入れる

s = objIE.Document.title
s1 = Split(s, "-")(0)
p = InStr(s1, " ")
result = Mid(s1, p + 1)

'分割した文字列を画面に表示

msgbox result

「VBscriptのエラーメッセージの意味」の質問画像

A 回答 (2件)

「As String」を削除してみてください。

    • good
    • 0

vbsには変数型という概念が基本ありません。

なので宣言のときはDim [変数名] だけでいいです。ってか、そうしないとエラーになります。プログラミング経験者なら型宣言したくなるってのはよくわかりますが、vbsではそう言うものだと思ってやるしかないです。
    • good
    • 0
この回答へのお礼

わかりました。

お礼日時:2019/04/03 21:27

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aと関連する良く見られている質問

QVBscriptでWebサイトから取得したtitleタグ情報をExcelに書き込めますか?

VBscriptでWebサイトから取得したtitleタグをテキストファイルに書き出すスクリプトを下記のとおり作成しました。titleタグ内のテキストを一次元配列にするスクリプトは別途作成しましたが、これをExcelのセルに書き込む方法がわかりません。ご存知の方教えてください。


--------
Option Explicit


Dim objIE
Dim objLink

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True

'IEを開く
objIE.navigate "http://XXXXX.co.jp/"


'タイトルをテキストファイルに書き出す
OutputText objIE.document.Title



'テキストファイルへ出力
Function OutputText(ByVal strMsg)

Dim objFSO
Dim objText

'ファイルシステムオブジェクト
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
’テキストファイルを開く
Set objText = objFSO.OpenTextFile("C:\work\title.txt", ForAppending, True)

objText.write strMsg
objText.write vbCrLf

objText.close

'オブジェクト変数をクリア
Set objFSO = Nothing
Set objText = Nothing

End Function

VBscriptでWebサイトから取得したtitleタグをテキストファイルに書き出すスクリプトを下記のとおり作成しました。titleタグ内のテキストを一次元配列にするスクリプトは別途作成しましたが、これをExcelのセルに書き込む方法がわかりません。ご存知の方教えてください。


--------
Option Explicit


Dim objIE
Dim objLink

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True

'IEを開く
objIE.navigate "http://XXXXX.co.jp/"
...続きを読む

Aベストアンサー

まず、質問で掲示しているコードでは、途中でエラーになると思います。
それに、別に1次元の配列にしようが、あまり関係ないと思います。
>これをExcelのセルに書き込む方法がわかりません。
VBScriptのExcelに関わる所が分からないのでしょうか。VBScript よりは、Excel VBAのほうがインテリセンスなどもあって、楽だと思います。

'----------------------
'//GetTitle.VBS
Const fn ="C:\work\title.txt"
Dim objIE
'Dim objLink
Dim objFSO
Set objIE = CreateObject("InternetExplorer.Application")

objIE.Visible = True
'IEを開く
objIE.Navigate2 "https://google.co.jp/" 'グーグルで試してみました。

Do While objIE.Busy Or objIE.ReadyState <> 4
WScript.Sleep 500
Loop

'タイトルをテキストファイルに書き出す
strMsg = objIE.document.Title
Call OutputText(strMsg)
'テキストファイルへ出力
objIE.Quit
Set objIE=Nothing
''MsgBox "Finish"

Sub OutputText(ByVal strMsg)
Dim objFSO
Dim objText
Const ForAppending=8

Set objFSO = CreateObject("Scripting.FileSystemObject")
'テキストファイルを開く
Set objText = objFSO.OpenTextFile(fn,ForAppending , True)

objText.write strMsg
objText.write vbCrLf

objText.close

'オブジェクト変数をクリア
Set objText = Nothing
End Sub


'//Export2Excel.VBS
Const fn ="C:\work\title.txt"
Dim objFSO
Dim objText
Dim i
Dim xlApp, Bk
Set objFSO =CreateObject("Scripting.FileSystemObject")
Set objText = objFSO.OpenTextFile(fn)
Set xlApp =CreateObject("Excel.Application")
xlApp.Visible=True
Set Bk = xlApp.Workbooks.Add
With Bk.ActiveSheet
Do While objText.AtEndOfLine<> True
i=i+1
.Cells(i,1).Value = objText.ReadLine
Loop
End With
objText.Close
Set objText = Nothing
Set objFSO = Nothing

まず、質問で掲示しているコードでは、途中でエラーになると思います。
それに、別に1次元の配列にしようが、あまり関係ないと思います。
>これをExcelのセルに書き込む方法がわかりません。
VBScriptのExcelに関わる所が分からないのでしょうか。VBScript よりは、Excel VBAのほうがインテリセンスなどもあって、楽だと思います。

'----------------------
'//GetTitle.VBS
Const fn ="C:\work\title.txt"
Dim objIE
'Dim objLink
Dim objFSO
Set objIE = CreateObject("InternetExplorer.Application")

objIE...続きを読む

Qvbaについて

vbaのプロパティやメソッドが一覧になっている
サイトはないものでしょうか?

javaのAPIの一覧のようなサイトが理想的です。
もしなければ、調べかたでも構いません。
回答よろしくお願いします。

Aベストアンサー

VBE の画面で F2 キーを押すと、[オブジェクト ブラウザー] という画面が開きます。
そこにすべて書かれています。

QVBscriptでExcel sheetの並び替えできますか?

Excel sheetのC列に数値が入っています。VBscriptでC列を基準に(他の列のデータと一緒に))降順に並び替えしたいのですが、可能でしょうか?
可能であればスクリプトのコーディングを教えて!

Aベストアンサー

>可能であればスクリプトのコーディングを教えて!
以下のコートで可能ではあっても、リクエストが細かすぎて、vbsにはふさわしくないように感じます。以下のコードは、ブラックボックス化してしまい、条件的に成立するのは難しいし、作者の私自身でも時間が経つとメインテも利かなくなりそうです。まず、コード自体を読み直してみてください。その内容が理解できるようなら、実用に差し支えないと思います。

しかし、目で見て確認してから、実行するのは、VBAしかないように思います。

'------------------
'//ExcelOpen.vbs
Dim objFS, FileName, extension
Dim xlApp,wb
Const SHN="Sheet1" 'シート名
FileName = WScript.Arguments.Item(0)
If WScript.Arguments.Count =0 Then
MsgBox "Excelファイルをドラッグ・ドロップしてください。"
WScript.Quit
End If
Set objFS = CreateObject("Scripting.FilesystemObject")
extension = objfs.GetExtensionName(FileName)
If Left(LCase(extension),3)<>"xls" Then
MsgBox "Excelファイルではありません。",64
WScript.Quit
End If
Set xlApp =GetObject(,"Excel.Application")
If xlApp is Nothing Then
Set xlApp = CreateObject("Excel.Application")
End If
xlApp.Visible = True
Set wb= xlApp.Workbooks.Open(FileName)
Dim Rng, Sh
'xlAscending=1, xlDescending=2, xlYes =1
With wb
With .Worksheets(SHN)
Set Rng =.Range("A1").CurrentRegion
'C列
Rng.Sort Rng.cells(1,3),2,,,,,,1
End With
.Save
.Close False
wscript.quit
End With
xlApp.Quit
Set Rng =Nothing
Set Sh = Nothing
Set wb = Nothing
Set xlApp = Nothing
Set objFS = Nothing

>可能であればスクリプトのコーディングを教えて!
以下のコートで可能ではあっても、リクエストが細かすぎて、vbsにはふさわしくないように感じます。以下のコードは、ブラックボックス化してしまい、条件的に成立するのは難しいし、作者の私自身でも時間が経つとメインテも利かなくなりそうです。まず、コード自体を読み直してみてください。その内容が理解できるようなら、実用に差し支えないと思います。

しかし、目で見て確認してから、実行するのは、VBAしかないように思います。

'------------------
'//...続きを読む

Qこのマクロ

(自分) マクロについて教えてください。エクセル2010です。(A) C6:T6に
84.69.62.59.58.53.52.50.49.48.47.46.41.40(ここの数字は8~18個

の数字が入り、9個の時とか12個の
時もあります。)
そのデータ(数字は同じではなくその行ごとによって違う。が28行目まで同一の単位で2行飛びであり)

同一シートにある(B) C32:T32に84.69.62.58.53.52.50.49(ここの数字は8個の数字だけ。)
そのデータ(数字は同じではなくその行ごとによって違う。が54行目まで同一の単位で2行飛び出あり)
(A)と(B)を比較して(B)には表示されていない(A)の抜けている数字(ここでは59.48.47.46.41.40)に
色を付ける(緑)のマクロを教えて頂きたいです。あと出来たら空白にする(59.48.47.46.41.40)のも教え
て頂きたいです。宜しくお願いします。



(答えてくれた人)
貴方の言う2行飛びとは、2行空けることではないのですか。
先頭が、6行目で2行あけていくと、最後は27行目になりますが。
Bのエリアも同様です。

それから、AとBで対応する行の比較でいいのですね。
6行目は32行目と比較、9行目は35行目と比較というように


(自分)
お急がしい所回答有り難うございます。6行目は32行目、8行目は34行目、10行目は36行目、12行目は38行目、14行目は40行目...28行目は54行目までという感じです。
すいません2行ではなく1行飛びでした。
AとBで対応する行の比較です。


と質問してマクロを教えてもらったのですが、

Sub Sample()
Dim i As Integer, j As Integer
Dim rng As Range
For i = 6 To 28 Step 2
Set rng = Range("C" & i + 26 & ":T" & i + 26)
For j = 3 To 20
If Application.CountIf(rng, Cells(i, j)) > 0 Then
Cells(i, j).Interior.ColorIndex = 4
End If
Next j
Next i
End Sub

同じ表があり、(X6:AO6、AS6:BJ6、BN6:CE6、CI6:CZ6、DD6:DU6、
DY6:EP6、ET6:FK6)
にも同じ事をしたいのですが、5行目のCとTの所をXとAOにしても動きませんというか、色がつきません。

マクロを教えてください。宜しくおねがいします。

(自分) マクロについて教えてください。エクセル2010です。(A) C6:T6に
84.69.62.59.58.53.52.50.49.48.47.46.41.40(ここの数字は8~18個

の数字が入り、9個の時とか12個の
時もあります。)
そのデータ(数字は同じではなくその行ごとによって違う。が28行目まで同一の単位で2行飛びであり)

同一シートにある(B) C32:T32に84.69.62.58.53.52.50.49(ここの数字は8個の数字だけ。)
そのデータ(数字は同じではなくその行ごとによって違う。が54行目まで同一の単位で2行飛び出あり)
(...続きを読む

Aベストアンサー

ソースをきっちりと読んでいませんが

> For j = 3 To 20

の部分、3→"C"、20→"T"に対応しているので、
この数値も変更する必要があると思います。
(”X"→24みたいに)

Qスーパーハッカーやホワイトハッカーが未だにプログラムをキーボードを使ってアナログな入力を10年前と変

スーパーハッカーやホワイトハッカーが未だにプログラムをキーボードを使ってアナログな入力を10年前と変わらずに未だにガチガチキーパンチャーしてるのって一般人から見たら超絶ダサいらしいですよ。

マツコデラックスがスーパーハッカーがプログラムをキーボードで打っていたのを見て「まだキーボードで打ってるんだ。人工知能や音声を文字化出来るようになってるのに10年前と変わらずキーボードで打ってるの?!」と言っていましたが、本当にそうだなと思いました。

未だにキーボードでプログラミングしてるって古くさいというか自動化、自動化と言ってる割にプログラマーが1番アナログだったりして。

Aベストアンサー

それは普通の文章入力しか想像できない人の発想ですね。

プログラミング言語では記号を多用しますが、これをいちいちダブルコーテーションだのアットマークだの言うのは手間だし、実は記号じゃなくてダブルコーテーションは”じゃなくそのままダブルコーテーションっていう文字列にしたかったんだけど…みたいな区別に困ることもあります。その辺をきれいに解決する手段が今のところないってこと、また「キーボード入力の方が話すよりも速くてしかも正確に入力できる」と言う事実があること、またいちいち口に出すと言うことは意外に労力を要すること、といった事情から音声認識でどうにかしようという空気にならないのでしょう。

QExcelのVBAで他のブックから転記したい

まだVBAの勉強始めたばかりですが、ExcelのVBAを使ってデータの検索と転記を行うプログラムを作っています。

やりたいことは、多数の同じ作りのファイル(Aブックとします)のB2~E2の内容を
Bブック内で検索を行い該当行がなければ、最後の行の下(最下行)に転記をし、
該当行があれば、同じ行のF2~G2に転記をすることです。

各ブックの構成です。

参照先:Aブック
Aブック内に別のシートがあり、その中から必要な事項をまとめた「転記用シート」があります。
その「転記用」シートにB2~I2まで数式が入力されています。

B2 到着日 数式:=IF(入力シート!S2="","",入力シート!S2)   セルの内容:3/18
C2 お名前 数式:=IF(入力シート!D6="","",入力シート!D6)   セルの内容:日本 太郎
D2 品名  数式:=IF(入力シート!E10="","",入力シート!E10)  セルの内容:AB123
E2 番号  数式:=IF(入力シート!O10="","",入力シート!O10)  セルの内容:AA123456


転記先:Bブック
シート名:新データシート
既に1000行ほど入力されています。
シートは、3行目がタイトル行で、4行目から実際のデータが入力されています。

No. 到着日  お名前    品名   番号     見積  金額 
A  B      C      D     E      F    G  
1  3/8   日本 太郎  ABC123  AA111111  100   100
2  3/11   東京 花子  BCD123  BB222222  500   600
3  3/11   大阪 一郎  CDE123  CC333333    0    0
4  3/11   日本 太郎  ABC123  AA111111  100   100
5  3/12   世界 二郎  BCD123  BB222223

Bブックには、AブックのC2、D2、E2と同じ値が既にあり、B2の日付のみ違うことがあります。
日付が違う場合は、一致していないと見なし、BブックにB2~G2まで転記をしたいのです。
また、日付をキーにすることもできません。

つまり、AブックのB2~E2がBブックにあったら、AブックのF2、G2をBブックの該当行に
転記し、条件に一致しない場合は、Bブックの最下行に追記したいのです。

なお、「For j = 4 To LastRow」
のところにDebug.printを挿入しました。
データが既に入力されていても「4」と表示され、
最下行に追記されてしまいました。

以下が、実際に自分でVBAで書いてみたのですが、
意図したとおりの結果を得ることができません。

どうか教えてください。
-----------------
Sub まとめtest()

Dim j As Long
Dim LastRow As Long

Dim s1 As Worksheet 'Aブックの「転記用」シート
Dim s2 As Worksheet 'Bブックの「新データ」シート

Dim objWbk As Workbook 'Aブック
Dim bk_name As Workbook 'Bブック

ThisWorkbook.Activate 'Aブックをアクティブ

Application.ScreenUpdating = False

Set objWbk = ActiveWorkbook
Set bk_name = Workbooks.Open("C:\報告書\記録帳.xlsx")

Set s1 = objWbk.Worksheets("転記用")
Set s2 = bk_name.Worksheets("新データ")

LastRow = s2.Cells(Rows.Count, "B").End(xlUp).Row

For j = 4 To LastRow

If Range("B" & j).Value = s1.Range("B" & 2).Value _
And Range("C" & j).Value = s1.Range("C" & 2).Value _
And Range("D" & j).Value = s1.Range("D" & 2).Value _
And Range("E" & j).Value = s1.Range("E" & 2).Value Then

Range("F" & j).Value = s1.Range("F" & 2).Value
Range("G" & j).Value = s1.Range("G" & 2).Value

Else
s1.Range("B2:F2").Copy
s2.Range("B" & LastRow + 1).PasteSpecial Paste:=xlPasteValues

Exit For
End If
Next

Set s1 = Nothing
Set s2 = Nothing

Application.ScreenUpdating = True

End Sub
----------------------------

※以前同じような内容で質問をしましたが、
条件に変更があったため、再度質問をいたしました。

まだVBAの勉強始めたばかりですが、ExcelのVBAを使ってデータの検索と転記を行うプログラムを作っています。

やりたいことは、多数の同じ作りのファイル(Aブックとします)のB2~E2の内容を
Bブック内で検索を行い該当行がなければ、最後の行の下(最下行)に転記をし、
該当行があれば、同じ行のF2~G2に転記をすることです。

各ブックの構成です。

参照先:Aブック
Aブック内に別のシートがあり、その中から必要な事項をまとめた「転記用シート」があります。
その「転記用」シートにB2~I2まで数式が...続きを読む

Aベストアンサー

もしかして,Bシートの”3/28”のところがB2セルではありませんか?
For j = 4 To LastRow +1にすればうまくいきました。
あと,IF文の所も直しておきました。
FOR文を下の通りにすればうまくいきましたよ。

---------------------------------
For j = 4 To LastRow + 1

If s2.Range("B" & j).Value = s1.Range("B" & 2).Value _
And s2.Range("C" & j).Value = s1.Range("C" & 2).Value _
And s2.Range("D" & j).Value = s1.Range("D" & 2).Value _
And s2.Range("E" & j).Value = s1.Range("E" & 2).Value Then

s2.Range("F" & j).Value = s1.Range("F" & 2).Value
s2.Range("G" & j).Value = s1.Range("G" & 2).Value

Exit For
End If

If j = LastRow + 1 Then
s1.Range("B2:F2").Copy
s2.Range("B" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
End If

Next
-------------------------------------------------

もしかして,Bシートの”3/28”のところがB2セルではありませんか?
For j = 4 To LastRow +1にすればうまくいきました。
あと,IF文の所も直しておきました。
FOR文を下の通りにすればうまくいきましたよ。

---------------------------------
For j = 4 To LastRow + 1

If s2.Range("B" & j).Value = s1.Range("B" & 2).Value _
And s2.Range("C" & j).Value = s1.Range("C" & 2).Value _
And s2.Range("D" & j).Value = s1.Range("D" & 2).Value _
And s2.Range("E" & j).Value = s1.Range("E" & 2).Value The...続きを読む

Q時刻文字列を判定する方法について

こんにちは
時刻文字列を比較する方法についておしえてください。

セルに時刻文字列 9:01とか12:34などが記載されていたら「OK」 
そうでない場合は「NG」となるような判定方法についておしえてください。
例)
12:34 MSGBOX ”OK”
1234  MSGBOX ”NG”
宜しくお願いいたします。

Aベストアンサー

どこかのセルに ”OK” または ”NG” と表示させたいなら…
例にある表示が、
 13:56
の書式であること【だけ】を対象としているなら、
 =IF(CELL("format",A1)="D9","GOOD","NG")
でOK。
 12:34:56
の書式なら「D9」の部分を「D8」にすればいい。

CELL関数について調べてみると幸せになれるかもしれません。

・・・
もしも入力時に ”時刻” 以外は弾きたいと言うのであれば「入力規則」で ”時刻” を指定してみましょう。
そして ”時刻” 以外の入力がされた時に返す「エラーメッセージ」を設定すれば良い。

QReDim

下記のコードを詳しく教えて
   
x2 = Range("C3:E5").Value

ReDim ans2(1 To 1, 1 To UBound(x2)) ←この部分の意味

    For i = LBound(x2, 2) To UBound(x2, 2)

      For j = LBound(x2) To UBound(x2)

       この部分の意味 → ans2(1, i) = ans2(1, i) + x2(j, i)

      Next j

    Next i

Aベストアンサー

全体として以下の様な動作をしています。
ans2(1,1) = Range("C3")~Range("C5")の合計を代入
ans2(1,2) = Range("D3")~Range("D5")の合計を代入
ans2(1,3) = Range("E3")~Range("E5")の合計を代入


> x2 = Range("C3:E5").Value

x2は、要素が行方向1~3、列方向1~3の二次元配列になります。
 x2(1,1)がC3セルの値
 x2(1,2)はD3セルの値
 …
 X2(3,3)がE5セルの値



> ReDim ans2(1 To 1, 1 To UBound(x2))

各列の合計を代入するans2は要素が行方向1~1,列方向が1~3の二次元配列の構成が必要となります。
その割り当てを行っています。



そして以下で各列の合計を計算しています。
> For i = LBound(x2, 2) To UBound(x2, 2)   '列方向の要素変化(1~3/C列~E列)
>   For j = LBound(x2) To UBound(x2)    '行方向の要素変化(1~3/3行~5行)
>     ans2(1, i) = ans2(1, i) + x2(j, i) '各列ごとに行の値を足しこむ
>   Next j
> Next i



試しに
 Range("A1:C1").Value = ans2
とすれば対応するセルに計算結果が表示されます。

全体として以下の様な動作をしています。
ans2(1,1) = Range("C3")~Range("C5")の合計を代入
ans2(1,2) = Range("D3")~Range("D5")の合計を代入
ans2(1,3) = Range("E3")~Range("E5")の合計を代入


> x2 = Range("C3:E5").Value

x2は、要素が行方向1~3、列方向1~3の二次元配列になります。
 x2(1,1)がC3セルの値
 x2(1,2)はD3セルの値
 …
 X2(3,3)がE5セルの値



> ReDim ans2(1 To 1, 1 To UBound(x2))

各列の合計を代入するans2は要素が行方向1~1,列方向が1~3の二次元配列の構成が必要となります...続きを読む

QVBAで配列を繰り返し宣言したい

配列を宣言する方法が分からなくて困ってます。
やりたいことは以下のような感じです。
Dim ARR_1 (300,10) AS Double
Dim ARR_2 (300,10) AS Double
Dim ARR_3 (300,10) AS Double

Dim ARR_i (300,10) AS Double
iは変数で50~200の値を取ります。
一つ一つ宣言していると大変な手間がかかってしまうので、繰り返し文などで簡単にできる方法があれば教えて頂けると助かります。

Aベストアンサー

こんにちは

「変数名を変えながら」というのは無理だと思いますが、元々そういうときの為に配列という概念が存在しているのではないでしょうか?
3次元配列にして
 ARR( i, 300, 10)
とかではダメなのでしょうか?

宣言するだけなら
 Dim ARR(50 To 200, 1 To 300, 1 To 10) As Double
とか。

あるいは、ご質問内容からは少し外れますが、Variantの1次元配列を作成しておいて、その各値に配列を格納するようなことも可能でしょう。
 Dim arr(200) As Variant
 arr(1) = Array("1", "2", "3")
 arr(2) = Array("A", "B", "V")
  ・・・

Q自分のパソコンではVBAが起動しますが‥ 他のパソコンでやってみると起動せずに インデックスが有効範

自分のパソコンではVBAが起動しますが‥
他のパソコンでやってみると起動せずに
インデックスが有効範囲にありませんの
エラーが出てしまいます。

何故でしょう?

だいたい下記のようなVBAになります。

Sub SendingSheet()
 Dim wb As Variant
 Dim WkBk As Variant
 For Each wb In Workbooks
  If (wb.Name) Like "FTN*【チェックシート】*.xls?" And wb.Name <> ActiveWorkbook.Name Then
   Set WkBk = wb
   Exit For
  End If
 Next
 If IsObject(WkBk) Then
  On Error Resume Next
  With WkBk
   ActiveSheet.Copy After:=WkBk.Worksheets(.Worksheets.Count)
ActiveSheet.name= "シートA"
   Beep  'コピーしたら音がなる
  End With
  If Err.Number <> 0 Then
   MsgBox Err.Number & " :" & Err.Description
  End If
  On Error GoTo 0
 Else
  MsgBox "該当するブックは開いていません。", vbExclamation
 End If
End Sub

----------------
よろしくお願いします。

自分のパソコンではVBAが起動しますが‥
他のパソコンでやってみると起動せずに
インデックスが有効範囲にありませんの
エラーが出てしまいます。

何故でしょう?

だいたい下記のようなVBAになります。

Sub SendingSheet()
 Dim wb As Variant
 Dim WkBk As Variant
 For Each wb In Workbooks
  If (wb.Name) Like "FTN*【チェックシート】*.xls?" And wb.Name <> ActiveWorkbook.Name Then
   Set WkBk = wb
   Exit For
  End If
 Next
 If IsObject(WkBk) Then
  On Error Resume Next
 ...続きを読む

Aベストアンサー

ちょっと割り込みさせていただきます。
ほとんど、前の方のやり取りは読まずに、コードを直してみました。

"FTN*【チェックシート】*.xls? というブックがあったら、そこにシートのコピーを送るというマクロですよね。
見た目は簡単なマクロのようですが、ひじょうにややこしくしているのは、マクロを搭載しているThisWorkbookの存在です。そのBookと、"FTN*【チェックシート】*.xls?は、同一ではない、というコードになっているからです。その条件は含め、ご質問者さんのコードは活かしました。

>"FTN*【チェックシート】*.xls?"
>上記のBookにコピーしてほしいのに
>アクティブBookへ名前を付けてコピーされて
>しまいます。

やはりそうなのですね。こちらのマクロでも、なぜかコピー後に、Active化が移動していないということです。(Excel 2016) //明示的にActiveの親オブジェクト(Book)から指定しなくてはならないようです。

ファイル(ブック)を特定化するロジックが大雑把ですね。一旦、見つけたブックを、さらに、Activeかどうかを調べるのであって、同時に両方の条件を調べたら、ブックがないことになってしまいます。

なお、こちらでは、エラーを避けるために、「 "シートA-" & .Worksheets.Count 'オプショナル」というオプションを設けました。それと、エラー・ストップというのは、通常は、ステップマクロで分かるものです。


'//標準モジュール(アドインを含む)
Sub SendingMySheet()
 Dim Wb As Variant
 Dim WkBk As Workbook
 Dim acWb As Workbook
 Dim sh As Worksheet

 On Error GoTo ErrHandler

 For Each Wb In Workbooks
  If Wb.Name Like "FTN*【チェックシート】*.xls?" Then
   If Wb.Name <> ActiveWorkbook.Name Then
    Set WkBk = Wb
    Exit For
   Else
    MsgBox Wb.Name & "はアクティブではできません。", vbExclamation
    Exit Sub
   End If
  End If
 Next Wb
 If Not WkBk Is Nothing Then
  Set acWb = ActiveWorkbook
  With WkBk
   acWb.ActiveSheet.Copy After:=.Worksheets(.Worksheets.Count)
   .ActiveSheet.Name = "シートA-" & .Worksheets.Count 'オプショナル
   Beep
  End With
 Else
  MsgBox "該当するブックは開いていません。", vbExclamation
 End If
ErrHandler:
 If Err() <> 0 Then
  MsgBox Err.Number & " :" & Err.Description
 End If
End Sub

ちょっと割り込みさせていただきます。
ほとんど、前の方のやり取りは読まずに、コードを直してみました。

"FTN*【チェックシート】*.xls? というブックがあったら、そこにシートのコピーを送るというマクロですよね。
見た目は簡単なマクロのようですが、ひじょうにややこしくしているのは、マクロを搭載しているThisWorkbookの存在です。そのBookと、"FTN*【チェックシート】*.xls?は、同一ではない、というコードになっているからです。その条件は含め、ご質問者さんのコードは活かしました。

>"FTN*【チェッ...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング