Excel VBA質問箱 IV

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

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


31181 / 76732 ←次へ | 前へ→

【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

で解決できました。
ありがとうございます。

0 hits

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

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