Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
5436 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【50803】シート自動挿入 おやじvba若葉マーク 07/8/16(木) 17:06 質問[未読]
【50805】Re:シート自動挿入 かみちゃん 07/8/16(木) 17:41 発言[未読]
【50806】Re:シート自動挿入 おやじvba若葉マーク 07/8/16(木) 18:03 お礼[未読]
【50803】シート自動挿入
質問  おやじvba若葉マーク E-MAIL  - 07/8/16(木) 17:06 -
引用なし
パスワード
   先日

アサヒライジング　　　****://db.netkeiba.com/horse/2003102338/
イクスキューズ　　　　****://db.netkeiba.com/horse/2004100763/
フレンチビキニ　　　　****://db.netkeiba.com/horse/2002100626/
例えば競争馬リストとゆうシートを作成し上記のようなリストがあります。
上記では3頭のアドレスが表示されていますが３頭分の１頭ずつのシートを自動で作成する方法は無いでしょうか。

と言う質問を投稿しましたが
おかげ様でできるようになりました。
ありがとうございます。

Sub uma()

Sheets("競争馬リスト").Select
Range("a1").Select
Set st = ActiveSheet
For I = 1 To 18
ActiveWorkbook.Worksheets.Add.Name = st.Range("A" & I)
　　ActiveCell.FormulaR1C1 = "=競争馬リスト!R[0]C[1]"
　　uma01 = Cells(I, 1).Value
　　　
　Dim strURL As String
　Dim FR As Range
　
　strURL = uma01
　
　With ActiveSheet.QueryTables.Add(Connection:= _
　　"URL;" & strURL, Destination:=Range("A1"))
　　.Name = "uma"
　　　　.AdjustColumnWidth = False
　　　　.WebSelectionType = xlEntirePage
　　　　.WebFormatting = xlWebFormattingNone
　　　　.Refresh BackgroundQuery:=False
　End With
　Set FR = Columns("A").Find("プロフィール*", , , xlWhole)
　If Not FR Is Nothing Then
　　If FR.Row > 4 Then
　　　Range("A1", FR.Offset(-4)).EntireRow.Delete xlShiftUp
　　　Range("B1").Resize(, Columns.Count - 1).Delete xlShiftToLeft
　　End If
　End If
　Set FR = Columns("A").Find("日付", , , xlWhole)
　If Not FR Is Nothing Then
　　Range("A2", FR.Offset(-1)).EntireRow.Delete xlShiftUp
　End If
　Set FR = Columns("A").Find("競馬DBトップ", , , xlWhole)
　If Not FR Is Nothing Then
　　Range(FR.Offset(-2), Cells(Rows.Count, "A").End(xlUp)).EntireRow.Delete xlShiftUp
　End If
　Next
End Sub

自動作成の際に競馬の出走馬が18頭フルのときは
For i = 1 To 18
で18頭分シートが作成されますが、例えば出走馬が12頭のときに12頭分のシート作成後に処理を終了させる方法と、ひとつのシートの自動生成後に別の処理をしてその後に次のシートを作成する方法はないでしょうか。
上記でやってみましたら1頭分は出来ましたが次のシート作成の際

.Refresh BackgroundQuery:=False

のところで止まってしまいました。
【50805】Re:シート自動挿入
発言  かみちゃん E-MAIL  - 07/8/16(木) 17:41 -
引用なし
パスワード
   こんにちは。かみちゃん　です。

最近競馬ネタが多いような気もするのですが・・・

>と言う質問を投稿しましたが
>おかげ様でできるようになりました。

以下のご質問ですね。
ｈｔｔｐ://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=49695;id=excel
（先頭４文字は、全角になっていますので、半角にしてください）

>自動作成の際に競馬の出走馬が18頭フルのときは
>For i = 1 To 18
>で18頭分シートが作成されます

出走馬ではなく、ＵＲＬが馬指定になっていませんか？
特定のレースに出走する全ての競走馬（「競争馬」ではなく）について取得したい
というのならば、出走頭数を把握する必要があると思いますが・・・

> 出走馬が12頭のときに12頭分のシート作成後に処理を終了させる方法

「競争馬リスト」のA列B列に取得したい馬名とＵＲＬを羅列して、その値がなくな
れば処理終了という繰り返し処理にすればいいかと思います。

たとえば、
uma01 = Cells(I, 1).Value
の直後に
If uma01 = "" Then Exit For
とすればFor 〜 Nextの繰り返し処理は終了し（抜け）ます

> ひとつのシートの自動生成後に別の処理をしてその後に次のシートを作成する方法

Next
の直前に
Call Macro1
としておくと、
Macro1 というマクロを処理して、次のシート作成にいきます。

>上記でやってみましたら1頭分は出来ましたが次のシート作成の際
>
>.Refresh BackgroundQuery:=False
>
>のところで止まってしまいました。

エラーメッセージも書きましょうね。
追加したセルの I 行目の1列目に値がない場合に
「予期せぬエラーが発生しました」
というエラーになります。

これは、
　ActiveWorkbook.Worksheets.Add.Name = st.Range("A" & I)
　ctiveCell.FormulaR1C1 = "=競争馬リスト!R[0]C[1]"
　ma01 = Cells(I, 1).Value
　　　
　Dim strURL As String
　Dim FR As Range
　
　strURL = uma01
というコードになっていて、
シート追加した後のアクティブセルに、
=競争馬リスト!R[0]C[1]
という数式を設定して、I行目の1列目の値を取得していますが、
このI行目の1列目の値は、アクティブシートから取得しています。
アクティブシートがどこになっているかをよく確認してください。
シートを追加していますので、「競争馬リスト」シートではなく、追加したシート
がアクティブシートになっています。

そのため、
　ma01 = Cells(I, 1).Value
を
　ma01 = Sheets("競争馬リスト").Cells(I, 2).Value
とすれば、この問題は回避できると思います。
なお、馬ごとのＵＲＬは、A列ではなく、B列のようですので、
〜.Cells(I, 2).〜
とする必要があると思います。
【50806】Re:シート自動挿入
お礼  おやじvba若葉マーク E-MAIL  - 07/8/16(木) 18:03 -
引用なし
パスワード
   ▼かみちゃん さん：
アドバイスありがとうございました。

Sub uma2()

Sheets("競争馬リスト").Select
Range("a1").Select
Set st = ActiveSheet
For I = 1 To 18
If Sheets("競争馬リスト").Cells(I, 2).Value = "" Then Exit For
ActiveWorkbook.Worksheets.Add.Name = st.Range("A" & I)
ActiveCell.FormulaR1C1 = Sheets("競争馬リスト").Cells(I, 2).Value
　uma01 = Range("a1").Value
　Dim strURL As String
　Dim FR As Range
　
　strURL = uma01
　
　With ActiveSheet.QueryTables.Add(Connection:= _
　　"URL;" & strURL, Destination:=Range("A1"))
　　.Name = "uma"
　　　　.AdjustColumnWidth = False
　　　　.WebSelectionType = xlEntirePage
　　　　.WebFormatting = xlWebFormattingNone
　　　　.Refresh BackgroundQuery:=False
　End With
　Set FR = Columns("A").Find("プロフィール*", , , xlWhole)
　If Not FR Is Nothing Then
　　If FR.Row > 4 Then
　　　Range("A1", FR.Offset(-4)).EntireRow.Delete xlShiftUp
　　　Range("B1").Resize(, Columns.Count - 1).Delete xlShiftToLeft
　　End If
　End If
　Set FR = Columns("A").Find("日付", , , xlWhole)
　If Not FR Is Nothing Then
　　Range("A2", FR.Offset(-1)).EntireRow.Delete xlShiftUp
　End If
　Set FR = Columns("A").Find("競馬DBトップ", , , xlWhole)
　If Not FR Is Nothing Then
　　Range(FR.Offset(-2), Cells(Rows.Count, "A").End(xlUp)).EntireRow.Delete xlShiftUp
　End If
　Next
End Sub

で解決できました。
ありがとうございます。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
5436 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free