• 締切済み

excel VBAでのループの方法

excel VBAでループの方法がわかりません、何方か教えて頂けませんか。 現在,下記様なコードを作成して一応目的に近くなりましが、1か所方法がわかりません。 sheets(時刻)の、(N6:N45 )の時刻データをsheets(基準値時刻)の(AI5:AI44)に転記して、その 転記されたデータを使い時刻を描画して、またsheets(時刻)を参照してこんどは、4列右の(R6:R45)のデータ読み取り、転記場所は、sheets(基準値時刻)の(AI5:AI44)の前回と同じセルに転記し、 そのノテータ を使い時刻を描画します。この繰り返しを行いたいのですが、 を[ j ≖ worksheets("時刻").cells(cnt2,10).value ] の列の10の数値を10,14,18、・・・と変化させたい のですが、うまくいきません。  読み取るデータは4列ずつ右に移動、転記場所は同じ場所、1回の読み込み、転記、描画が完了 してから、読み取るデータの位置のみ変更(4列右へ移動)、後の動作は同じ。 この繰り返しをしたいのです。 '-----------時刻取得・転記------------ for x = 1 to 50 For cnt2 = 6 To 45 Step 1      '6行から45行を1stepずつ j = Worksheets("時刻").Cells(cnt2, 10).Value '時刻sheetsから時刻取得  Worksheets("基準値時刻").Cells(cnt2 - 1, 35).Value = j '取得時刻を基準値時刻sheetへ   Next cnt2 '---------------時刻を描画-------------- For cnt4 = 5 To 44 Step 2 k = Worksheets("基準値時刻").Cells(cnt4, 38).Value l = Worksheets("基準値時刻").Cells(cnt4, 39).Value m = Worksheets("基準値時刻").Cells(cnt4 + 1, 38).Value n = Worksheets("基準値時刻").Cells(cnt4 + 1, 39).Value With Worksheets("勾配計算").Shapes.AddLine(k, l, m, n) .Line.Weight = 1 .Line.ForeColor.RGB = vbBlue End With Next cnt4 Next x 以上がコードの一部です。よろしくお願いいたします。   環境は, OSは  windows 8.1 です。

  • diwk85
  • お礼率83% (141/168)

みんなの回答

回答No.3

あっそうか!(#1です。) > 転記場所は、sheets(基準値時刻)の(AI5:AI44)の前回と同じセルに転記し、 38:39列=AL:AM に、AI列を参照した数式が設定してあって、 その計算結果を元に直線コネクタを描画する、ということかしら? ならば、都度転記する理由もいくらか理解できます。 その場合、そして補足が必要な場合は、 AL:AM はどんな数式なのかも報せて下さいね。 場合によっては、その演算もVBAに任せた方が、 処理は安定するかも知れないので、そういった含みも確認してみて下さい。 取り急ぎ、気が付いたことを追記、まで。

diwk85
質問者

お礼

 ありがとう御座いました。ご指摘頂きました点を検討しました。そして いろいろと試みました。その結果、無事解決できました。 すぐにご解答頂きながら遅くなりまして申し訳ありませんでした。  毎回、独りよがりな質問をして、みなさんにご迷惑かけております。今回はと思い注意しましたが 説明不足でした。 今後ともよろしくお願いいたします。

  • Nouble
  • ベストアンサー率18% (330/1783)
回答No.2

For cnt2 = 6 To 45 Step 1      '6行から45行を1stepずつ j = Worksheets("時刻").Cells(cnt2, 10).Value '時刻sheetsから時刻取得  Worksheets("基準値時刻").Cells(cnt2 - 1, 35).Value = j '取得時刻を基準値時刻sheetへ   Next cnt2 を Worksheets("基準値時刻").range(Cell(5, 35),ceii(44,35)).Value = Worksheets("時刻").range(Cell(6, 10),cell(45,10)).Value に変え、 Worksheets("基準値時刻").range(Cell(5, 35),ceii(44,35)).Value = Worksheets("時刻").range(Cell(6, 10+x*4-1),cell(45,10+x*4-1)).Value と、する で、如何ですか? 挙げられたものでは 読込み元cells内の10の値が xの影響を受けていません よね? ずっと10のままです 此処が問題点では? お役に立てていたならば幸いです。

回答No.1

こんにちは。 読解に自信が持てませんから推察を交えての暫定回答です。 ★の行、2ヶ所、書換えています。 一発でニーズを捉え切れているか疑問が残りますから、保全の為、 ブックのコピーを作ってからコピー側で動作を確認してみて下さい。  Worksheets("基準値時刻") への参照が煩雑なので、  With フレーズを使って全体をブロックにしてあります。  .Cells から始まる参照は、  すべてWorksheets("基準値時刻").Cells の意味です。 > 転記場所は、sheets(基準値時刻)の(AI5:AI44)の前回と同じセルに転記し、 ループの中で繰り返し同じ場所に転記するのは、 結果的にループの最後の処理しか反映されないですよね? (元データの最終列だけ記録として残すのなら、それはループの中に書く必要はないですし) なので、非常に特殊な扱い方です。 特別な理由(例えば元データの列単位で処理を中断したものを閲覧したい?とか) が無いならば、見る者(時が経ち開発意図を忘れた頃の自分を含む) を困惑させる原因になりますから(今回、回答がなかなか付かない理由もこれ)、 (転記の処理過程を省き)'基準値時刻'シートの値を直接参照するように した方が、解り易いのかも知れません。 何か理由があってのことなら、 ご自身が今知っているだけでは、不安が残りますから、 スクリプト中のコメント、質問文、に明記した方がいいです。 一応、想定した中で確率が高そうに思える前提への答として、 以下のコードを書いています。 動作を確認し、望んだ結果が得られない場合は、 望んだ結果とどう違うのか明らかにしてください。 その際、 '時刻'シートのデータサンプルを一例(+何時から何時までとか)、 '勾配計算'シートのレイアウト概要 などの説明を添えておけば、こちらでも実際に動作確認が出来るようになり、 より的確な対応が可能になると思います。 他、 説明では"N列から"なのか"J列から"なのか、とか、 何列めまでループするのか、等、不足した情報も付け加えておいてください。 (以下はJ列から、50回、右に4列ずつステップするようにループする例です。) ' ' -------------------------------------------------------------- Dim j As Variant Dim k As Single, l As Single, m As Single, n As Single ' 座標(時刻) Dim x As Long, cnt2 As Long, cnt4 As Long ' ループカウンタ ' ' --------------------------------------------------------------   With Worksheets("基準値時刻")     '-----------時刻取得・転記------------     For x = 10 To 206 Step 4 ' ★←ココ★何列めから何列めまでなのか指定してください       For cnt2 = 6 To 45 ' Step 1     '6行から45行を1stepずつ         j = Worksheets("時刻").Cells(cnt2, x).Value ' ' ★←ココ★時刻sheetsから時刻取得         .Cells(cnt2 - 1, 35).Value = j '取得時刻を基準値時刻sheetへ       Next cnt2       '---------------時刻を描画--------------       For cnt4 = 5 To 44 Step 2         k = .Cells(cnt4, 38).Value         l = .Cells(cnt4, 39).Value         m = .Cells(cnt4 + 1, 38).Value         n = .Cells(cnt4 + 1, 39).Value         With Worksheets("勾配計算").Shapes.AddLine(k, l, m, n)           .Line.Weight = 1           .Line.ForeColor.RGB = vbBlue         End With       Next cnt4     Next x   End With ' ' --------------------------------------------------------------

関連するQ&A

  • excel VBA で条件の設定方を教えて下さい。

    今、斜線を引きその斜線データの最初のセルに数値で(1とか3とかの数値の)条件をつけて置き、その条件で、太さ、色等を変えて斜線を引きたいのですがうまくいきません。何方か教えて頂けませんか。 --------------------- dim myrange as range workheets("補助計算").range("c8:c47").value = worksheets("時刻").range("c8:c47").value workheets("補助計算").range("g8:h47").value = worksheets("時刻").range("g8:h47").value with worksheets("時刻")     v=worksheets("時刻").range("m2").value+12'描画本数     for i = 12 to v step 1'設定可能本数50本 set myrage = worksheets("補助計算").range("t3:t47") myrange.value = .range(.cells(3,i),.cells(48,i)).value for cnt = 75 to 113 step 2 e = worksheets("ダイヤ").cells(cnt,10).value       f = worksheets("ダイヤ").cells(cnt,11).value       g = worksheets("ダイヤ").cells(cnt+1,10).value       h = worksheets("ダイヤ").cells(cnt+1,11).value with worksheets("ダイヤ").shapes.addline(e,f,g,h) .line.weight = 1.1 .line.forecolor.rgb = vbblue end with next cnt next i end with ----------------------- 上記コードで、斜線が何本か引かれます、その際、データ元のセルに数値の条件、例えば、1 とか3とかの数値を入力されているときは、それによって、斜線の色、又は線の太さをかえたいのですが、指定の仕方は、時刻シートの時刻の上欄セルに、線の指定のセル、太さ指定のセルに別々に指定おき、それを参照して、線の色、太さをかえたいのですが、いろいろ試みましたがうまくいきません。上記コードにどのように追加コードをすればよいか何方か教えていただけませんか。できれば、線の色は3色以上設定できればありがたいです。、

  • ワークシート名を変数に格納する方法

    VBA初心者です。ワークシートが5つあり各シートにデータを転記するマクロを作成したいのですがワークシート名を変数にしてループ処理することはできるのでしょうか? 下記はワークシート名"H"にだけ転記するマクロを作成してみましたがこの後がわからず悩んでいます。よろしくお願いします。 Dim データ行 As Integer Dim cnt As Integer Dim データ数 As Integer cnt = 4 データ行 = Cells(Rows.Count, 8).End(xlUp).Row For データ数 = 11 To データ行   If Worksheets("入力").Cells(データ数,1).Value= "2"Then Worksheets("H").Cells(cnt, 6).Value = Worksheets("入力").Cells(データ数, 8).Value Worksheets("H").Cells(cnt, 7).Value = Worksheets("入力").Cells(データ数, 9).Value Worksheets("H").Cells(cnt, 8).Value = Worksheets("入力").Cells(データ数, 27).Value Worksheets("H").Cells(cnt, 9).Value = Worksheets("入力").Cells(データ数, 19).Value Worksheets("H").Cells(cnt, 10).Value = Worksheets("入力").Cells(データ数, 20).Value Worksheets("H").Cells(cnt, 11).Value = Worksheets("入力").Cells(データ数, 21).Value Worksheets("H").Cells(cnt, 12).Value = Worksheets("入力").Cells(データ数, 10).Value Worksheets("H").Cells(cnt, 13).Value = Worksheets("入力").Cells(データ数, 11).Value Worksheets("H").Cells(cnt, 14).Value = Worksheets("入力").Cells(データ数, 22).Value Worksheets("H").Cells(cnt, 15).Value = Worksheets("入力").Cells(データ数, 23).Value cnt = cnt + 1 End If Next データ数

  • エクセル 転記ループが上手くいきません

    ToDoファイルに記載した内容を別ファイルの管理シートに転記したいと考えています。 ToDoの4列目、管理シートの1列目に共通の管理IDを持たせてそこで紐づけさせ、ToDoの11列目に記載した内容を管理シートの72列目、ToDoの22列目に記載した内容を管理シートの73列目・・・といういう形で転記していきたいです。 以下のように作ってみたのですが、これでは転記されず、ここにもう一つループを加えると転記されるようになります。 (今は For i = 1 To last1 と For ii = 1 To last2の二つのループですが、もう一つ For j = 1 To last2 とかを加えると転記されます。) なぜなのか分かりません。 どなかた理由と解決方法を教えていただけないでしょうか? どうぞよろしくお願いいたします。 Sub 管理シートへ貼り付け() Dim BookA As Workbook Dim BookB As Workbook Dim last1 As Long Dim last2 As Long Dim i As Long Dim ii As Long Workbooks.Open Filename:="管理シート.xlsm" Windows("ToDo.xlsm").Activate Set BookA = Workbooks("ToDo.xlsm") Set BookB = Workbooks("管理シート.xlsm") last1 = BookA.Sheets("ToDo").Cells(Rows.Count, 1).End(xlUp).Row last2 = BookB.Sheets("管理シート").Cells(Rows.Count, 1).End(xlUp).Row With BookA.Sheets("ToDo") For i = 1 To last1 For ii = 1 To last2 If .Cells(i, 4) = BookB.Sheets("管理シート").Cells(ii, 1) Then BookB.Sheets("管理シート").Cells(ii, 72) = .Cells(i, 11) BookB.Sheets("管理シート").Cells(ii, 73) = .Cells(i, 22) BookB.Sheets("管理シート").Cells(ii, 74) = .Cells(i, 23) BookB.Sheets("管理シート").Cells(ii, 75) = .Cells(i, 24) BookB.Sheets("管理シート").Cells(ii, 76) = .Cells(i, 25) End If If .Cells(i, 1).Value = "貼付け後削除" Then Rows(i).Hidden = True End If Exit For Next Next End With MsgBox "転記が終わりました" End Sub

  • エクセルVBAについて

    こんにちは。エクセルVBAを勉強して間もない初心者です。現在、作っているものがありますが、分からなくなってしまったのでご指導をお願いいたします。エクセル2000を使用しています。 《Sheets構成》 Sheets(1)とsheets(5)があります。※Sheets(2)~Sheets(4)はここでは省略します。 Sheets(1)には、Range(cells(19,2),cells(49,8))に、ランダムに商品CDが入力されています。 Sheets(5)には、Range(cells(7,2),cells(31,2))に商品CDが入力されています。 《やりたい事》 Sheets(1)に入力されている商品CDが、Sheets(5)にも入力されているかチェックし、もしSheets(5)に入力されていればSheets(1)の商品CDが入力されているセルに、"○"を表示させ、入力されていなければ、空白にしたいと考えています。 そのため、自分なりにマクロを作成してみましたが、どうしても空白にする事ができませんので、詳しい方のご指導を頂ければと思います。 《作成したマクロ・・・(変数の宣言はここでは省略させて頂きます)》 sub 商品CDチェック() For n = 2 To 8      'Sheets(1)B列~H列の変数 For m = 19 To 49  'Sheets(1)商品CDが入っている行  mm = 7        'Sheets(5)の商品CDが入っている行 Do         'Sheets(1)とsheets(5)の商品CDのチェック If Sheets(1).Cells(m, n).Value = Sheets(5).Cells(mm, 2).Value Then Sheets(1).Cells(m, n).Value = "○"     'Sheets(5)に商品CDが入力されていれば○ End If mm = mm + 1 Loop Until Sheets(5).Cells(mm, 2) = "" Next m Next n 《その他》 調べたところ、検索するにはFindメソッドを使用するような事が書いてあるものも見つけましたが、使い方がわかりません。もし、上記のマクロを作りたい時はFindを使ったほうが良い場合は、Findを使ったマクロも教えて頂けると、非常に参考になります。 よろしくお願いいたします。

  • Excel VBA; 複数のループ処理

    ↓のようなコードがあります。 Dim i As Long, MaxRow1 As Long, MaxRow2 As Long MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To MaxRow1 Worksheets("Sheet1").Cells(i, 1).Value = i . Next i For i = 1 To MaxRow2 Worksheets("Sheet2").Cells(i, 1).Value = i . Next i これらを最大行の多いシートに合わせて、パフォーマンスを良くしたいと思います。 同様の処理をシート1、シート2で実施しているので纏めて記述したいです。 シート1、シート2に対する処理をサブルーチンにする方法しかありませんか? どなたかお願いします。 If MaxRow1 >= MaxRow2 Then For i = 1 To MaxRow1 Else For i = 1 To MaxRow2 End If Worksheets("Sheet1").Cells(i, 1).Value = i Worksheets("Sheet2").Cells(i, 1).Value = i . Next i

  • E xcel bva でデータの転記ができない

    時刻シートから補助計算シートへデータを転記したいのですがデータ元の時刻シート側は順次右側へ1列ずつ移動し、転記先の補助計算シートの転記場所は、変化しない一定な箇所に1件ごとに上書きしていく ようにしたい。いま下記のコードを実行すると転記できます。  worksheets("補助計算").range("p3:p48").value = worksheets("時刻").range("l3:l47").value この1件の転記はできます、これを複数のデータを転記できるようにしたいのですが。 for i = 12 to 50 step 1 worksheets("補助計算").range("p3:p48").value = worksheets("時刻").range(cells(3 , i),cells(47,   i)..value next i end sub として試みましたがうまくできません、どこに間違いがありますか、どなたか教えて頂けませんか。 OS はwindows 8.1です。

  • EXCELのシートを並べ替えすると・・・

    エクセルのシートを並べ替えようと思って こちらで調べてようやく並べ替えができるようになったのですが、幾つかあるデータの中で実行するとエラーが出るものがあります。 シートの名前は1日~31日&集計という構成なのですが、下記を実行すると実行エラー9:インデックスが有効範囲にありません!とでます…デバックを押すと Worksheets(CStr(Wwh.Cells(N, 1).Value)).Move After:=Sheets(N) のところが黄色になっています。 同じようなシートの構成があるデータで試してみると成功するものと失敗するものがありもう何がなにやら(;´Д`) 何か変更しないとだめなんでしょうか? 分かる人がいたらアドバイスお願いします。 Sub SortSheets() Dim Wwh As Worksheet Dim N As Integer Application.ScreenUpdating = False Sheets.Add Before:=Worksheets(1) Set Wwh = ActiveSheet For N = 2 To Worksheets.Count   Cells(N - 1, 1).Value = Worksheets(N).Name   Cells(N - 1, 2).Value = _   Application.GetPhonetic(Worksheets(N).Name) Next N Range("A1").CurrentRegion.Sort Key1:=Range("B1"), _   Order1:=xlAscending, Header:=xlNo, OrderCustom:=1 '昇順 'Range("A1").CurrentRegion.Sort Key1:=Range("B1"), _   Order1:=xlDescending, Header:=xlNo, OrderCustom:=1 '降順 For N = 1 To Range("A1").End(xlDown).Row   Worksheets(CStr(Wwh.Cells(N, 1).Value)).Move After:=Sheets(N) Next N For N = 2 To Worksheets.Count   If Worksheets(N).Visible = xlSheetVisible Then     Worksheets(N).Activate     Exit For   End If Next N Application.DisplayAlerts = False Wwh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True Set Wwh = Nothing End Sub

  • VBAプログラミングの質問です。

    Sheet1の第2列に行番号、4列に列番号、5列にそこの値が書かれたデータが並んでいます。 1 1 967 2 1 687 ……… x y 802 ……… x行、y列に802を代入するという感じです。全部で57985データあります。 前の回答を参考にして、48881データまではSheet2に For k = 1 To 48881 Worksheets("Sheet2").Cells(1 + Worksheets("Sheet1").Cells(k, 2), 1 + Worksheets("Sheet1").Cells(k, 4)) = Worksheets("Sheet1").Cells(k, 5) Next k このようにプログラムを書いて納まって、残りの57985-48881=9104データの行列はSheet2に納まらなかったので、Sheet3に書こうと思い、下のように書きましたがプログラムがうまく動きませんでした。他にも試しましたが初心者のためダメでした。 Dim n As Long Dim m As Long n = 9104 m = 48881 For k = 1 To n Worksheets("Sheet3").Cells(1 + Worksheets("Sheet1").Cells(k + m, 2), 1 + Worksheets("Sheet1").Cells(k + m, 4)) = Worksheets("Sheet1").Cells(k + m, 5) Next k 48881というのが大きいため動かないと考えられますが、どのように対処したらよいかわかりません。教えてください。お願いします。

  • エクセル VBA

    VBA内で、そのVBAの実行を制御することは可能でしょうか? 下のようなコードを作ったのですが、 Sub 承認書作成() Dim ws0 As Worksheet, ws1 As Worksheet, r1 As Range Dim i As Long Dim nyuryoku(), chikuseki() Set ws0 = Worksheets("承認書作成") Set ws1 = Worksheets("顧客データ") Set ws2 = Worksheets("業者コード") Set ws3 = Worksheets("承認通知書") Worksheets("顧客データ").Select Range("テーブル1[[#Headers],[NO.]]").Select Selection.End(xlToRight).Select Selection.End(xlDown).Select Selection.ListObject.ListRows.Add AlwaysInsert:=False Range("B7").Select nyuryoku = Array("b5", "d5", "f5", "h5", "j5", "l5", "n5", "p5", "b6", "d6", "f6", "h6", "j6", "l6", "n6", "p6", "b4", "d4") '転記したいセルの位置 chikuseki = Array("0", "1", "5", "6", "8", "9", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "53", "54") '転記先の列のオフセット値  Set r1 = ws1.Range("f" & Rows.Count).End(xlUp).Offset(0) 'データ蓄積セル  For i = 0 To UBound(nyuryoku) r1.Offset(0, chikuseki(i)).Value = ws0.Range(nyuryokui)).Value '入力 Next MsgBox "入力完了" Dim lRowNum As Long '転記先となる行番号を求める lRowNum = ws1.Cells(Rows.Count, "b").End(xlUp).Row '転記 ws3.Cells(6, "d").Value = ws1.Cells(lRowNum, "j").Value ws3.Cells(17, "g").Value = ws1.Cells(lRowNum, "c").Value ws3.Cells(22, "g").Value = ws1.Cells(lRowNum, "l").Value ws3.Cells(22, "ac").Value = ws1.Cells(lRowNum, "ab").Value    Set ws0 = Nothing   Set ws1 = Nothing End Sub ここに、     If call Macro1 then call 承認書作成  '上のマクロです    Else: Msgbox"中止" 「Macro1を実行しないと承認書作成マクロを実行できない」 という コードを組み込みたいのですが、うまくいきません。 VBA内に同じVBAを組み込むことは不可能なのでしょうか?

  • エクセルVBAで

    登録ボタンを作りたいのですが うまくいきません。 応答無しになってしまいます。 仕事でコードを入力して、住所やその他の関連事項を 登録して、検索し、封筒に宛名印刷し、登録内容の修正をしたいと思っています。 登録ボタンは下記のようなものを作りました。 Private Sub CommandButton1_Click() Dim bk As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim cnt1 As Long Set bk = ThisWorkbook Set sh1 = bk.Worksheets("現場登録検索") Set sh2 = bk.Worksheets("一覧") cnt1 = 6 Do While sh2.Cells(cnt1, 2).Value <> "" cnt = cnt1 + 1 Loop '得意先CD sh2.Cells(cnt1, 2).Value = sh1.Cells(2, 3).Value '現場CD sh2.Cells(cnt1, 3).Value = sh1.Cells(3, 3).Value '送り方 sh2.Cells(cnt1, 22).Value = sh1.Cells(4, 3).Value '封筒 sh2.Cells(cnt1, 23).Value = sh1.Cells(5, 3).Value MsgBox "登録できました。" End Sub 何が悪いのでしょうか? よろしくお願い致します。

専門家に質問してみよう