ループが走りません

前へ 次へ
このQ&Aのポイント
  • VBAコードで作成したループが正常に動作しない問題が発生しています。
  • 「最終」シートのC列から始まり最終行までのデータを検索し、条件に一致する場合には「最終」シートのG列に値を入力する処理を行いたいです。
  • しかし、現在のコードではループが正しく動作しておらず、原因が分かりません。アドバイスをいただけると幸いです。
回答を見る
  • ベストアンサー

ループが走りません

Sub COIN() Dim shSAI As Worksheet Dim shTAN As Worksheet Dim inROW As Long Set shSAI = Sheets("最終") Set shTAN = Sheets("単価") For inROW = 10 To shSAI.UsedRange.Rows.Count If shTAN.Range("C" & inROW) = shTAN.Range("C4") Then shSAI.Range("G" & inROW).Value = shSAI.Range("G6").Value End If Next Set shSAI = Nothing Set shTAN = Nothing End Sub 上記のようなコードを書きました 動作としては「最終」シートC10から下へ続く文字に対し、「単価」シートC4と同一であれば、 「最終」シートG10から下へ続くG列に、「単価」シートG6の数値をあてはめたいと考えております。 「最終」シートのC列は、場合によっては下に続くため、C10から始まり最終行までの検索するループを作りたいのですが、ループが走りません。 当方全くの素人でありますが、問題点がお分かりの方がおりましたら、教えて下さい。

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

  • ベストアンサー
回答No.1

はじめまして。 これは、ExcelマクロのVisualBasicですよね。 私も一時期これでがんばってました。 さて、これはループが走らないのではなくシート名の指示が違っているのです。 ご提示のマクロでは単価シートのC列と単価シートのC４を比較しているので、条件に一致しないか、単価シートのG6の数値が単価シートの相当行のG列に書き込まれることになっているので気づかれていないのではと予測します。 エラーが出ないのでさぞ悩まれたことでしょうね。わかります。 正解は Sub COIN() Dim shSAI As Worksheet Dim shTAN As Worksheet Dim inROW As Long Set shSAI = Sheets("最終") Set shTAN = Sheets("単価") For inROW = 10 To shSAI.UsedRange.Rows.Count If shSAI.Range("C" & inROW) = shTAN.Range("C4") Then shSAI.Range("G" & inROW).Value = shTAN.Range("G6").Value End If Next Set shSAI = Nothing Set shTAN = Nothing End Sub End Ifの直前2行のシート名が入れ替わると動きます。試してみました。 初心者といわれますが、私の初心者の時より上手い気がします。 ここからスタートして、頑張ってくださいね！ あと、シート名は特に必要がなければ半角英数を推奨します。 何かのときにバグが出るんです。経験済みです。では！

y-bankrupt
質問者

お礼

早速の回答ありがとうございます 余りにテンパっていて、エクセルのマクロVBAであることすら、表記しておりませんでした。 回答の内容は正にその通りだったようです、失礼ながらコードをコピペしたところ、思った通りの動作をしました。 ありがとうございます

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 特定の文字以外を入力すると別シートに表記する方法

    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim StrRow As Long Dim TgtCol As Long Dim MaxRow As Long Dim ChgRow As Long Dim PutSh1 As Worksheet Dim PutSh2 As Worksheet Dim PutSh3 As Worksheet Dim PutCol As Long Dim PutRow As Long Dim ChgRng1 As Range Dim ChgRng2 As Range Dim ChgRng3 As Range StrRow = 5 MaxRow = 35 If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub Set PutSh1 = ThisWorkbook.Sheets("Sheet2") Set PutSh2 = ThisWorkbook.Sheets("Sheet3") Set PutSh3 = ThisWorkbook.Sheets("Sheet4") With ThisWorkbook.Sheets("Sheet1") Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列 Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列 Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列 End With ChgRow = Target.Row If Not Intersect(Target, ChgRng1) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh1, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng2) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh2, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng3) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh3, ChgRow, Target.Value End If End Sub 以前質問させて頂いた内容で追加の質問です。 Sheet1の指定したセルに「ー（ハイフン）」の文字がある時は、Sheet2〜4に転送（表記）しない方法を追加する場合はどの様にすれば宜しいでしょうか？

  • カットして隣のB列に順番にペーストするマクロ

    発注と納品の確認マクロを作成しました。 Sheet1の列を検索して、Sheet2にあればその数字のあるセルを赤くするのですが、 それを以下のように変更することは可能でしょうか？ Sheet1の列を検索して、Sheet2にあれば、Sheet2上でその数字をカットして隣のB列に上から順番にペーストします。 宜しくお願いします。 Sub 発注と納品の確認マクロ() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If myCt = 0 Then c2.Interior.ColorIndex = 3 Else c2.Interior.ColorIndex = 43 End If myCt = myCt + 1 End If Next c2 If myCt = 0 Then c1.Interior.ColorIndex = 6 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • 過去のリンクhttp://okwave.jp/qa

    過去のリンクhttp://okwave.jp/qa9671557.html いつもありがとうございます。今回はシート1のA3セルに4901777という数字を入れた時にC4セルに改行された時にNAME1と表示されるコード、、なのですが、試作だけにコードの見映えがよくありません。何十何百となった時にコードが冗長化しそうです。スリムなコードにするにはどうしたら良いでしょうか？ よろしくお願いします^^ ' ///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:E3").Value = ws1.Range("A3:E3 ").Value Set ws1 = Nothing Set ws2 = Nothing End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Application.EnableEvents = True '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) 'A列とE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws2.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。（コード） ws2.Cells(s, "C") = Mid(ws1.Cells(i3, "A"), 3, 5) '追加する文字を転記する。（コード2） s = s + 1 End If Next i3 'A列データの最終行までループ Next i ws2.Range("C3:C300").Replace What:="01777", Replacement:="NAME1", LookAt:=xlPart, MatchCase:=True ws1.Range("C4").Value = ws2.Range("C3").Value ws1.Activate Set ws1 = Nothing Set ws2 = Nothing End Sub

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： 　Sheet2のC列に　0　 があれば 　Sheet1のB列に　愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • ワークシートのChangeイベントについて

    シート１のA1セルの値を変更したらシート２のA1・A2・A3と変更内容を順に記録するような以下のようなコードがありますが、うまく動作しません。問題点を指摘していただければ大変助かります。 【Worksheet】 Private Sub Worksheet_Change(ByVal Target As Range) Static r Dim s As Range Set s = Sheets("sheet1").Range("$a$1").Value If s Is Nothing Then Else If r = "" Then r = 1 Sheets("sheet2").Cells(r, 1) = Sheets"sheet1").Range("$a$1").Value r = r + 1 End If 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 -------------------------------------------------------------- 教えて下さい。お願いします。

  • [vba]任意の順位でセルを抽出したい

    下記のデータがあるとします。これを理科の点数順位で上位ｘ位まで新たに書き直したい。 　　　　　　　(sheet1) A　　B　　C　　D　　　E　　　F　　　G 1 ___　　国語　算数　理科　社会　英語 2 たかし 75 67 47 96 77　 3 ひろし 46 78 65 67 87 4 やすし 78 98 33 95 90 5 しおり 65 78 67 89 98 6 まなみ 88 56 78 98 76 　　　　　　　　　↓ 　　　（異なるシート:sheet2へ） A　　B　　C　　D　　　E　　　F　　　G 1 ___　　国語　算数　理科　社会　英語　 2 まなみ 88 56 78 98 76　　 3 しおり 65 78 67 89 98 4 ひろし 46 78 65 67 87 'この場合、理科の点数上位3位までを抽出 Sub test11 () Dim a As Worksheet, b As Worksheet Dim c As Range Set a = Sheets("sheet1") Set b = Sheets("sheet2") Set c = a.Range("E2", "E6") 　'理科の点数範囲 For x = 1 To 3 　'上位3位まで WorksheetFunction.Large(r, x) この先、large関数やrank関数を使って組んでみようと試みましたが うまくいきませんでした。いい方法がありましたら教えてください。よろしくお願いします。

  • VBで既存エクセルシートを新規ブックにコピー

    VB6,Excel2003です。 既存のエクセルシートを新規ブックにコピーする プログラムを作成してみましたが タスクバーに新規ブックのタスクバーボタンが２つできてしまいます。 どこが原因か教えてください。よろしくお願いします。 Private Sub Command1_Click() Dim xlsApp As Excel.Application Dim xlsBookTemp As Excel.Workbook 'コピー元ブック Dim xlsBookCopy As Excel.Workbook 'コピー先ブック Dim xlsSheetTemp As Excel.Worksheet 'コピー元シート Dim xlsSheetCopy As Excel.Worksheet 'コピー先シート Set xlsApp = CreateObject("Excel.Application") Set xlsBookTemp = xlsApp.Workbooks.Open("C:\Temp.xls") Set xlsSheetTemp = xlsBookTemp.Sheets(1) Set xlsBookCopy = xlsApp.Workbooks.Add Set xlsSheetCopy = xlsBookCopy.Sheets(1) xlsApp.Visible = True 'コピー元のSheet1を新規ブックにコピーする xlsSheetTemp.Copy Before:=xlsSheetCopy 'コピー元のブックは閉じる xlsBookTemp.Close '///新規ブックの編集処理/// Set xlsSheetTemp = Nothing Set xlsBookTemp = Nothing Set xlsSheetCopy = Nothing Set xlsBookCopy = Nothing Set xlsApp = Nothing End Sub

  • エクセル　ＶＢＡ　シートの選択　

    windows XP でエクセル２０００を使っています。 Sub aaa() Sheets("Sheet1").Select Dim a As String a = Cells(2, 4) Sheets(a).Select Range("A1").Select End Sub というマクロだと　セルに入っている値のシート名を探してくれます。 ですが Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Intersect(Target, Range("B11:b683")) Is Nothing Then Exit Sub Worksheets("Sheet1").Range("C2").Value = Target.Value Dim b As String b = Range("C2).value （←ここをcellsにしてもダメ） Sheets(b).Select Range("A1").Select End Sub これだとsheets(b)を選びません。Sheets(b).Selectのところが黄色くなります。 何処が間違えているのでしょうか。 全くの素人ですが、仕事で必要に迫られています。 わかりやすく回答・解説くれると助かります。

  • VBAエラー '1004' について

    VBA初心者です。 下のプログラムの★部分で 「実行時エラー'1004' アプリケーション定義またはオブジェクト定義のエラーです。」 というエラーが発生します。 どなたか原因を教えていただけないでしょうか？？ Dim aRange As Range Dim bRange As Range Set aRange = Range(Sheets("シートA").Range("A3"), Sheets("シートB").Range("A3").End(xlDown)) ★ Set bRange = Range(Sheets("シートB").Range("A3"), Sheets("シートB").Range("A3").End(xlDown)) 下のシートBの範囲取得と同じことをしているつもりなのですが、うまくいきません。 どうぞよろしくお願い致します。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する