• ベストアンサー
  • 困ってます

vbaの繰り返し処理について

vbaです。 Sub Test1() Dim Str As String Dim Pnt1 As Long Dim Pnt2 As Long Str = Range("A1") Pnt1 = InStr(Str, "重 http://") If Pnt1 <= 0 Then Exit Sub Pnt2 = InStr(Pnt1, Str, "要") If Pnt2 <= 0 Then Range("B1") = Mid(Str, Pnt1 + 2) Else Range("B1") = Mid(Str, Pnt1 + 2, Pnt2 - (Pnt1 + 2)) End If End Sub という式でA1からA2.A3と下にURLが入っており空欄になるまで同じ処理をしたいのですがどのように変更すれば作動しますでしょうか?

共感・応援の気持ちを伝えよう!

  • 回答数4
  • 閲覧数36
  • ありがとう数1

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.4
  • kkkkkm
  • ベストアンサー率59% (961/1627)

> str=のところで引数は省略できませんとでてしまいました。 元の宣言の所は省略していますので追加してください。 StrはMyStrとかにした方がいいと思いますよ。 Dim Str As String Dim Pnt1 As Long Dim Pnt2 As Long

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございました。途中で訂正などしたり、追加での質問にも答えていただいたりとても助かりました。 ありがとうございます。

関連するQ&A

  • EXCEL2002 VBAのループ処理について

    セルB1~B24に入力した数字を i とすると、 コマンドボタンを押したときに、セルB1~B24にの全てに値が入力されていて、 セル( F & i )が空白であれば、そこにセルA1の値を入れるようなマクロを作成しています。 セル( F & i )への入力は、セルB1~B24の全部に数値が入力されており、セル( F & i )が空白があるときのみ処理が実行されるように。どちらかが満たされない場合には、メッセージボックスを表示し、処理しないようにしたいのですが、どうしても途中まで入力されてしまいます。 以下のようなコードですが、何か良い方法はないでしょうか? Private Sub CommandButton1_Click() 'ロール確認 Dim 入力 As String, パレット As String Dim i As Long, t As Long For i = 1 To 24 入力 = Range("B" & i) パレット = Range("F" & i) If 入力 = "" Then MsgBox "aaa" Exit For End If 'パレットNo.転記 If パレット <> "" Then MsgBox "bbb" Exit For ElseIf パレット = "" Then Range("F" & 入力).Value = Range("A1").Value End If Next i End Sub

  • VBAの処理を軽くしたい

    各行ごとに5回セルを参照した結果を吐き出すプログラムを作成しています。 200行前後の処理が必要なのですが、現在のコードではあまりにも処理が重くなっています。 とにかく処理を軽くしたいのですが、どのような方法が考えられるでしょうか? 初心者なのでコードも含めてご教示頂けたら幸いです。 Sub test(b, c, d) Dim i1, i2 As Long Dim A1 As String  For i1=0 To Cells(Rows.Count, 1).End(xlUp).Row For i2 = 0 To 5 If Range(b).offset(i1, i2).Value = "x1" Or Range(c).offset(i1, i2).Value = "x1" Then A1 = "XXX" ElseIf Range(b).offset(i1, i2).Value = Range(c).offset(i1, i2).Value Then A1 = "YYY" Else A1 = "ZZZ" End If Range(d).offset(i1, i2).Value = A1 Next i2 Next i1 End Sub

  • EXCEL VBA で列の数字のみを修正No.2

    前回の応用の質問になります。 EXCEL VBA で列の数字のみを修正したいのですが 内容としては (1)カッコ内文字はそのまま維持 (2)添付資料のN001から始まっているまたはN001以外の始まる、ある機械加工プログラムに   N053,N054を挿入しプログラム内容はそのまま変更なく使用 ここで始めたいNナンバー数値(例N075からの連番)にマクロで変換したいのですが おすすめのコードを教えてください。 (※SHEET1のA列に記載されているとして) 前回の質問時はN001からの連番を以下のコードでできました。 Sub test() Dim i As Long Dim j As Long Dim str As String i = 1 j = 1 str = Worksheets("sheet1").Range("A" & i).Value Do While str <> "" If Left(str, 1) = "N" Then str = "N" & Format(j, "000") & Mid(str, 5, Len(str) - 4) Worksheets("sheet1").Range("A" & i).Value = str j = j + 1 End If i = i + 1 str = Worksheets("sheet1").Range("A" & i).Value Loop End Sub いろいろコードを触ってみましたが思うように出来ずに困っています。 よろしくお願いします

その他の回答 (3)

  • 回答No.3
  • kkkkkm
  • ベストアンサー率59% (961/1627)

No1の追加です。 Range("B2") は Range("B1")に変わったんですね。 同じ行のB列だとしたら Range("B1") を Cells(i, "B").Value に変更してください。

共感・感謝の気持ちを伝えよう!

  • 回答No.2
  • kkkkkm
  • ベストアンサー率59% (961/1627)

No1の訂正です。 Debug.Print Pnt1 は不要です。

共感・感謝の気持ちを伝えよう!

  • 回答No.1
  • kkkkkm
  • ベストアンサー率59% (961/1627)

以下のどちらかで試してみてください。 Dim i As Long For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row Str = Cells(i, "A").Value 'Range("A1") Pnt1 = InStr(Str, "重 http://") Debug.Print Pnt1 If Pnt1 <= 0 Then Exit Sub Pnt2 = InStr(Pnt1, Str, "要") If Pnt2 <= 0 Then Range("B2") = Mid(Str, Pnt1 + 2) Else Range("B2") = Mid(Str, Pnt1 + 2, Pnt2 - (Pnt1 + 2)) End If Next Dim i As Long: i = 1 Do While Cells(i, "A").Value <> "" Str = Cells(i, "A").Value 'Range("A1") Pnt1 = InStr(Str, "重 http://") Debug.Print Pnt1 If Pnt1 <= 0 Then Exit Sub Pnt2 = InStr(Pnt1, Str, "要") If Pnt2 <= 0 Then Range("B2") = Mid(Str, Pnt1 + 2) Else Range("B2") = Mid(Str, Pnt1 + 2, Pnt2 - (Pnt1 + 2)) End If i = i + 1 Loop

共感・感謝の気持ちを伝えよう!

質問者からの補足

ありがとうございました。str=のところで引数は省略できませんとでてしまいました。原因は分かりますでしょうか?

関連するQ&A

  • エクセルVBAの条件指定が上手くいきません

    「7を超えたら、For Eachステートメントを抜けなさい」という条件を入れたいのですが、 7を超えても処理が継続し困っています。 勉強不足で申し訳ないですが、ご教授願います。 【やりたいこと】 まず、セルB1&#65374;D3までのセルの値(9つ)が、7を超えない条件で1を加算していきます。 加算したときの値はE&#65374;Gの列に貼り付けていきます。 7を超えた時点でFor Eachステートメントを抜けます。 また、B1&#65374;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 お手数ですが、宜しくお願いいたします。

  • VBA 処理の途中でエラーが出る

    VBA初心者です。 シート1とシート2があり、 シート1の表の列Mと列Nにそれぞれシート2のデータを参照する COUNTIFS関数を入れたいと思い、以下のように作成しました。 ※シート1は場合よって行の最後行が違います。 Dim Test As String Dim Test2 As String Dim i As Long For i = 1 To Cells(Rows.Count,1).End(xlUP).Row Test=Range("A" & i ) If MyStr<>""Then Range("M" & i) ="=COUNTIFS(Sheet2!,A:A"& Test &",Sheet2!B:B,M1"&")" End If Test2=Range("A" & i ) If MyStr<>""Then Range("N" & i )="=COUNTIFS(Sheet2!,A:A"& Test2 &",Sheet2!B:B,N1"&")" End If Next i この内容にて、処理が成功していたのですが、 急に、行150のあたりで処理が止まり、実行時エラー(アプリケーション定義またはオブジェクト定義のエラーです) が出るようになりました。 行150より上の方は、列Mと列N共にCOUNTIFS関数が入っています。 この場合、どのようにすればよろしいのでしょうか? エラーの対処、または別の記述方法があれば、ご教授頂きたく存じます。

  • Excel2010 VBA 条件色付け

    Sub sample() Dim r As Range For Each r In Range("q6:q30") If myIsNumeric(r) Then r.Offset(0, 1).Value = "数字" Else r.Offset(0, 1).Value = "文字" End If Next End Sub Function myIsNumeric(Target As Range) Dim r As Range Dim buf, tmp Dim flg As Boolean Dim i As Integer buf = Target For i = 1 To Len(buf) tmp = Mid(buf, i, 1) If IsNumeric(tmp) Then flg = True Exit For End If Next myIsNumeric = flg End Function を数字が入ってたら塗りつぶさないで、 数字が入ってなかったら塗りつぶすように直したいです。 あああ→塗る あああ1&#65293;1→塗らない 住所→塗る 住所12→塗らない

  • 2010 excel マクロ 記号の変化

    エラー発生で強制終了になってしまいます。2007年のexcelで作成したものですが、2010だと強制終了になってしまいます。 内容は□をダブルクリックすると■になるように作っています。 記述は2003年からのマクロ記述なので、変化が必要なのでしょうか? Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'セルをダブルクリックすると、・→○→△→×→・と変更する。 Dim S1 As String Dim S2 As String Dim S01 As String Dim S02 As String Dim S03 As String Dim S04 As String S1 = "□" S2 = "■" S01 = "・" S02 = "○" S03 = "△" S04 = "×" On Error GoTo ERR_12 sCheckXY S1, S2 sCheckX1234 S01, S02, S03, S04 sChangeXY S1, S2 Exit Sub ERR_12: End End Sub Sub sChangeXY(X As String, Y As String) '選択セルに□があれば■に変える Dim Str0 As String 'str1の左端 Dim Str1 As String 'strの右側更新 Dim Str2 As String 'strの左側更新 Dim Str20 As String 'strの左側一部保存 Dim L As Long Dim M As Long Dim N As Long Str1 = ActiveCell.Text L = Len(Str1) Debug.Print L If L = 0 Then End End If For N = 1 To L Debug.Print Str2 Str0 = Left(Str1, 1) If Str0 = X Or N = L Then If Str20 <> "" Then If N = L Then Str20 = Str20 + Str0 End If If MsgBox(Str20 & "  はチェックしますか?", vbYesNo, "選択肢") = vbYes Then Str2 = Str2 + Replace(Str20, X, Y) Str20 = Str0 Else Str2 = Str2 + Replace(Str20, Y, X) Str20 = Str0 End If Else Str20 = Str0 End If Else Str20 = Str20 + Str0 End If Str1 = Right(Str1, L - N) Next N ActiveCell.Value = Str2 End Sub Sub sCheckXY(X As String, Y As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X Then ActiveCell.Value = Y End ElseIf ActiveCell.Text = Y Then ActiveCell.Value = X End End If End Sub Sub sCheckX1234(X1 As String, X2 As String, X3 As String, X4 As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X1 Then ActiveCell.Value = X2 End ElseIf ActiveCell.Text = X2 Then ActiveCell.Value = X3 End ElseIf ActiveCell.Text = X3 Then ActiveCell.Value = X4 End ElseIf ActiveCell.Text = X4 Then ActiveCell.Value = X1 End End If End Sub

  • VBAで教えてください。

    データがないときはExitSubしたいのですが、何処に記述すれば良いでしょうか? Sub 削除() Dim i As Long If MsgBox("データを削除します。よろしいですか?", vbYesNo) = vbYes Then Sheets("リスト").Select i = 5 Do Until i = 200 If Cells(i, 5).Value = Sheets("マスタ登録").Range("D5") Then Cells(i, 1).EntireRow.Delete End If i = i + 1 Loop Else Exit Sub End If End Sub

  • エクセルvba IFについて(複数条件)

    エクセルvbaでのifの構成について教えてください。 (1)*あいうえお   →あいうえお (2)あいうえお*   →あいうえお (3)*あいうえお*   →あいうえお     に変換させたいです。 以下のマクロを作りました。 Sub test() Dim c As Range For Each c In Selection.Cells If InStr(c, "*") = 1 Then c = Mid(c, InStr(c, "*") + 1) ElseIf InStrRev(c, "*") > 0 Then c = Left(c, InStrRev(c, "*") - 1) End If Next End Sub これだと(1)(2)はできるのですが、(3)は2回実行しないと全ての*が削除できないです。 1回の実行で「あいうえお」ができるようにするにはどうしたらよいのでしょうか。 本当は、 ****あいうえお**  →あいうえお のように、*(半角)や*(全角)が文字の前後についている場合、すべての*(半角)と*(全角)削除したいのですが(できれば1回の実行で)、そのようなことは可能なのでしょうか。 midやleftの作り方も間違っていれば、それもご教授ください。 よろしくお願いします。

  • エクセルVBAのイベントで質問です。

    ダブルクリックイベントで、G12:G31の範囲の文字列をB10:B27の範囲(最下行)に入れていくものを使っていますが、新たにH12:H31にある文字列もダブルクリックするとC10:C27の範囲(最下行)に入れていけるようにしたいと思います。 どのようにすればいいでしょうか。 ご存知の方いらっしゃればお教えいただけると助かります。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Dim i As Long Dim flg As Boolean If Intersect(Target, Range("G12:G31")) Is Nothing Then Exit Sub If IsEmpty(Target.Value) Then Exit Sub With Worksheets("シートA") For i = 10 To 27 If .Range("B" & i).Value = "" Then .Range("B" & i).Value = Target.Value flg = True Exit For End If Next i If flg = False Then MsgBox .Name & " がいっぱいです。" End If End With Cancel = True End Sub

  • エクセルVBAを教えて下さい

    エクセルの表で -AB C D E F 1年月--1801 2------ 3------ 4------ (-)は空欄でセルE1=18、F1=1とします。 コントロールボックスをつかって Private Sub Command登録_Click() Dim d1 As Long Dim d2 As Long Dim ret As Variant Dim FindValue As String Dim TotalAddress As String If Range("E1").Value = "" Or Range("F1").Value = "" Then MsgBox "該当する場所にデータが入っていません。", vbCritical Exit Sub End If d1 = Range("A65536").End(xlUp).Offset(1).Row d2 = Range("B65536").End(xlUp).Offset(1).Row FindValue = """" & Range("E1").Value & Range("F1").Value & """" TotalAddress = Range("A1").Resize(d1).Address & "&" & Range("B1").Resize(d1).Address ret = Evaluate("MATCH(" & FindValue & "," & TotalAddress & ",0)") If IsError(ret) Then Cells(d1, 1) = Range("E1").Value Cells(d2, 2) = Range("F1").Value Else MsgBox "既に同じ組み合せがあります。", vbInformation End If End Sub というものを作ったのですが、E1=18、F1=1及びコマンドボタンを別シートに作成し、上記の表への登録をできるようにしたいのですが、なにかいい方法はありませんか?

  • またまた エクセルのユーザー定義で

    前回以下のようなコードを教えていただきましたが、この変換を複数列で使えるようにするにはどうしたらいいのでしょうか? D,G,N,Q,X,AA,の列に効かせたいのですが。 Private Sub worksheet_change(ByVal Target As Range) If Intersect(Target, Columns(1)) Is Nothing Or Selection.Count <> 1 Then Exit Sub Dim str As String str = Target Application.EnableEvents = False If Target <> "" Then If Len(str) = 7 Then Target = Left(str, 5) & "A" & Mid(str, 6, 1) & "-" & Right(str, 1) Else Target = Left(str, 5) & "A" & Mid(str, 6, 2) & "-" & Right(str, 1) End If End If Application.EnableEvents = True End Sub

  • VBA ループ処理 "型が違います"エラー

    "sheet1"のA1:J1を"sheet2"のA1:J1にコピー "sheet1"のA2:J2を"sheet2"のA2:J2にコピー "sheet1"のA3:J3を"sheet2"のA3:J3にコピー これを"sheet1"A:Jが空欄になるまでループさせたいのですが、 どうしてもエラーが出てしまいます。。。 前回も同様の質問をして、回答を頂いたのですが、 自分なりに応用を利かせてやってみたら、エラーが出てしまいます>< ------------------------------------------------------------ Sub cpy2() Dim i As Long Dim Sht1 As Range Dim Sht2 As Range Set Sht1 = Sheets("Sheet1").Range("A1:J1") ←("A1")ではエラーは出ません。 Set Sht2 = Sheets("Sheet2").Range("A1:J1") ←("A1")ではエラーは出ません。 For i = 0 To 65535 If Sht1.Offset(i) <> "" Then ←ここでエラーが出ます"型が違います" Sht2.Offset(i) = Sht1.Offset(i) Else Exit For End If Next End Sub -------------------------------------------------------------- 教えて下さい。お願いします。