Excel VBA質問箱 IV

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

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


31190 / 76738 ←次へ | 前へ→

【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頭のアドレスが表示されていますが3頭分の1頭ずつのシートを自動で作成する方法は無いでしょうか。

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

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

のところで止まってしまいました。

0 hits

【50803】シート自動挿入 おやじvba若葉マーク 07/8/16(木) 17:06 質問
【50805】Re:シート自動挿入 かみちゃん 07/8/16(木) 17:41 発言
【50806】Re:シート自動挿入 おやじvba若葉マーク 07/8/16(木) 18:03 お礼

31190 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free