VBAの処理効率を向上させるための変更方法
- VBAのDo~Loopを使用している際に、処理効率を向上させるための変更方法について教えていただきたいです。
- 現在、30回繰り返すDo While文を使用していますが、条件が満たされる間に繰り返すように変更したいです。
- 具体的な変更方法や注意点について教えていただけると助かります。
- ベストアンサー
VBA Do~Loopについて
VBA勉強中です。 マクロの作成は完了しているのですが、処理効率について指摘を受け、 その際に助言もいただいたのですが、自身の勉強不足、理解不足で どのように変更すれば良いのか分からず、教えていただきたいです。 Do While Ax2 <= 30 で30回繰り返すのではなく (Cells(Ax2,"B").Value <> "" ) の間繰り返すように変更したいです。 ---------------- Sub test() Dim File1(30) As string Dim Sheet1(30) As string Dim Sheet2(30) As string Dim Cnt As Integer Ax1=1 Ax2=7 Do While Ax2 <= 30 If Cells(Ax2, "B").Value <> "" Then File1(Ax1) = Cells(Ax2, "B").Value Sheet1(Ax1) = Cells(Ax2, "C").Value Sheet2(Ax1) = Cells(Ax2, "D").Value Cnt =Ax1 End If Ax1 = Ax1 + 1 Ax2 = Ax2 + 1 Loop End Sub ---------------- お手数ですが、よろしくお願いいたします。
- flapper39
- お礼率100% (1/1)
- Visual Basic
- 回答数1
- ありがとう数2
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
> Do While Ax2 <= 30 で30回繰り返すのではなく > (Cells(Ax2,"B").Value <> "" ) の間繰り返すように変更したいです。 Do While Cells(ax2, "B").Value <> "" でいけると思いますが、たとえば処理対象の最終がB40とした場合それ以前にデータがないセルがあれば(たとえばB28)そこで止まります。
関連するQ&A
- Excel VBA のDo Until Loopについて
こんばんは Excel VBAの初心者です。 Do Until Loopを使って B列の値が変わるところ（下記の表だと、空白からコスモスに変わる、4行目。コスモスからチューリップに変わる6行目。チューリップから菊に変わる8行目。）に行を挿入させたいと思い、下記のマクロを組んだのですが、Do Until Loopが理解できませんでした。 どうしたら良いのか教えて頂けないでしょうか。 宜しくお願い致します。 Excelのシート B1 項目 B2 空白 B3 空白 B4 コスモス B5 コスモス B6 チューリップ B7 チューリップ B8 菊 Sub 行の挿入() Dim y As String Cells(2, 2).Select y = Cells(2, 2).Value Do Until Cells(2, 2).Value <> y ActiveCell.Offset(1).Select Selection.EntireRow.Select Selection.Insert shift:=xlDown Loop End Sub
- ベストアンサー
- その他（プログラミング・開発）
- Do～Loopステートメント
Do～Loopステートメントで使わな方が良いステートメントとは？ Do～Loopステートメントで「古いから使わない方がよい」、と言われたことがあるのですが どれの事だか忘れてしまいました。 Sub test() セルのA1～A10に1～10を入力する i = 1 Do While i < 11 Worksheets("Sheet1").Cells(i, 1).Value = i i = i + 1 Loop End Sub これは一般的だから使ってもよいと思います。 Sub test() セルのA1～A10に1～10を入力する i = 1 Do Until i = 11 Worksheets("Sheet1").Cells(i, 1).Value = i i = i + 1 Loop End Sub これもよく見かけます。 Do While,Do Until以外にもloopステートメントってありますか？ あと使わない方が良いステートメント、私の勘違いでなければ教えてください。
- ベストアンサー
- オフィス系ソフト
- エクセル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 何が悪いのでしょうか? よろしくお願い致します。
- ベストアンサー
- その他（プログラミング・開発）
- VBAのハイパーリンクにつきまして
以前に質問をさせていただき、こちらでベストアンサーを決定した後に急きょ変更があったところがあり、わからなくなってしまいこちらに戻ってきた次第です。 http://okwave.jp/qa/q8743521.html にて質問をさせていただきました内容について、以下のVBAで解決できております。 しかし、抽出したファイル名にハイパーリンクが欲しいという要望を受けてしまいました。 ハイパーリンクのＶＢＡについていろいろ調べましたが、この記述方法に追加して実行する方法が全く分かりませんでした。 お分かりになる方がいましたら、この内容にハイパーリンクをつける方法をお教えいただけますでしょうか。よろしくお願いいたします。 Sub Macro1() Dim i As Long Dim myPath As String, Flnm As String ReDim Flnmfp(0) As String Dim WS1 As worksheet Set WS1=ThisWorkbook.sheets("sheet1") myPath="望みのフォルダパスを入力" Call fpFileName(myPath, Flnmfp ) 'フォルダ内のファイル名取得 If Ubound(Flnmfp)=0 Then 'フォルダにファイルが無ければ終了 Exit Sub End if For i =1 to Ubound(Flnmfp) Workbooks.open filename := Flnmfp(i) Flnm=Dir(Flnmfp(i)) With Workbooks(Flnm).sheets("sheet1") WS1.Cells(2, i).value=.Range("G5").value WS1.Cells(3, i).value=.Range("G6").value WS1.Cells(4, i).value=.Range("K7").value WS1.Cells(5, i).value=CStr(.Range("G9").value) & CStr(.Range("N9").value) & CStr(.Range("P9").value) '同じ要領で望みのセルを記入する WS1.Cells(8, i).value=Flnm End with Workbooks(Flnm).close Savechanges:=False Next i End Sub Sub fpFileName(ByVal myPath As String, ByRef Flnmfp() As String) 'サブフォルダも含め全部のxlsファイル名をフルパスで取得する Dim cnt As Long, buf As String, f As Object buf = Dir(myPath & "\*.xls") Do While buf <> "" cnt = Ubound(Flnmfp) + 1 ReDim Preserve Flnmfp(cnt) Flnmfp(cnt)= myPath & "\" & buf buf = Dir() Loop With CreateObject("Scripting.FileSystemObject") For Each f In .GetFolder(myPath).SubFolders Call fpFileName(f.Path, Flnmfp) Next f End With End Sub
- ベストアンサー
- Visual Basic
- VBA 九九 Do While
VBAのDo Whileステートメントを使って九九の表をつくりたいのですが、何度やっても途中で詰まり、実行に至りません。 For NextとDo untilではできたと思うのですがDo Whileがどうしてもわからなくて… どなたか助けてください。お願いします。 Sub 九九計算_for() Dim i, j As Integer For i = 1 To 9 For j = 1 To 9 Cells(i, j).Value = i * j Next Next End Sub Sub 九九計算_do_until() j = 1 Do i = 1 Do Cells(j, i).Value = i * j i = i + 1 Loop Until i = 10 j = j + 1 Loop Until j = 10 End Sub
- ベストアンサー
- Visual Basic
- Do Loopの処理結果が思うように得られません。
VBAの知識がなく、コピペで作業しています。 笑わないで見てください。 作業内容は 「集計用フォルダ内にあるファイル（60個くらいあります）の情報を取得してデータベース化する」 です。 下記のプログラムを作ってみたのですが、ThisWorkbookに各ファイルのデータが 一行ずつずれて貼り付けられてしまい、最終行の一つ下に貼り付けられていません。 画面を見ていると、ファイルは一つずつ開いて閉じてを繰り返しているのですが、 貼り付けは一括で行われます。 ThisWorkbookの扱いで、散々苦労して作ったのですが、あと一歩というところで つまづいてしまいました。 アドバイス、よろしくお願いいたします。 Sub フォルダ内エクセルファイル値取り出し() Dim FName As String Dim FPath As String Dim cnt As Integer Dim r As Long '画面更新オフ Application.ScreenUpdating = False '累積データがある列のデータ下端を取得 cnt = Cells(Rows.Count, 1).End(xlDown).Offset(1, 0).Row FPath = "C:\Documents and Settings\******\デスクトップ\集計用フォルダ(このフォルダは書込み専用です）" '対象フォルダのパス ChDir FPath FName = Dir("*.xls") Do While FName <> "" Workbooks.Open FName Worksheets(1).Range(Selection, ActiveCell.SpecialCells(xlLastCell)) _ .Copy Destination:=ThisWorkbook.Sheets(1).Cells(cnt, 1) cnt = cnt + 1 ActiveWorkbook.Close FName = Dir() Loop '画面更新オン Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
- VBA Do Until ~ Loop 内にif
Excel VBAマクロにて、C列のセルのうちOKと書かれたセルのみ塗りつぶすコードを作成したつもりなのですが、動いてくれません。エラー表示も出ません。間違いを指摘して下さる方、あるいは別の書き方があるという方、教えていただけないでしょうか。 下記私が作成したものです。C列にAと書かれたセルが現れるまで処理をするようにしています。 Sub sample() Dim i As Long i = 1 Do Until Cells(i, "C").Value = ”A" If Cells(i, "C").Value = "OK" Then Cells(i, "C").Interior.ColorIndex = 5 End If i = i + 1 Loop End Sub
- 締切済み
- Visual Basic
- 複数フォルダに格納されたファイル名取得VBA
お世話になっております。 あるフォルダに複数のフォルダが格納されており、更にそのフォルダの中にあるファイルの情報を取得するプログラムを書いたのですが、実行すると下記のようなエラーとなってしまいます。 ■エラー プロシージャの呼び出し、または引数が不正です 下から3行目、「buf = Dir()」が問題であることはわかるのですが、 何が問題でどのように解決したらいいかわかりません。 どなたかご教授の程よろしくお願い致します(>_<) ------------------------------------------------------------------------ Sub test() Dim buf As String Dim fName As String Dim msg As String buf = Dir("*.*", vbDirectory) Do While buf <> "" If GetAttr(buf) And vbDirectory Then If buf <> "." And buf <> ".." Then fName = Dir(CurDir & "\" & buf & "\" & "*.jpg") Do While fName <> "" cnt = cnt + 1 Cells(cnt, 1) = buf Cells(cnt, 2) = fName msg = msg & buf & "\" & fName & vbCrLf fName = Dir() Loop MsgBox msg End If End If buf = Dir() Loop End Sub ------------------------------------------------------------------------ これが実現できないと細かい作業を毎日繰り返す事となり、 かなり業務不可が高いです。。 繰り返しになってしまいますが、どなたかご回答よろしくお願い致します。
- ベストアンサー
- その他（プログラミング・開発）
- VBAにてリストボックスに表示された文字をエクセルのセルにコピペするには
先日、ここで教えてもらった以下の内容で、幾つかのテキストボックスに表示された内容のうち、電話番号をエクセルのセルに転記する方法が、上手くいきません。”検索"名のシート上で実行します。 過去のログを参考にしましたが、解決できませんでした。 またお世話になりますが、だれか教えてください。 Private Sub CommandButton1_Click() Dim Namae As String Dim MeNamae As UserForm Dim ken As String Namae = TextBox1.Text Set MeNamae = UserForm1 Call 検索(Namae, MeNamae) End Sub Public Sub 検索(ByVal Namae As String, ByRef MeNamae As UserForm) Dim Nagasa As Integer Dim i As Long Dim MaxRows As Long Dim kensaku As Worksheet Dim KensakuChar As String Dim ListNamae As String Dim ListChar As String Dim KBanme As Integer Dim LBanme As Integer Set kensaku = Worksheets("顧客データ") MaxRows = kensaku.UsedRange.Rows.Count Nagasa = Len(Namae) MeNamae.ListBox1.Clear For i = 3 To MaxRows ListNamae = kensaku.Cells(i, 3) KBanme = 0 LBanme = 0 Do Do While Nagasa >= KBanme KBanme = KBanme + 1 KensakuChar = Mid(Namae, KBanme, 1) If KensakuChar <> " " Then Exit Do End If Loop Do While Nagasa >= LBanme LBanme = LBanme + 1 ListChar = Mid(ListNamae, LBanme, 1) If ListChar <> " " Then Exit Do End If Loop If KensakuChar = ListChar Then If Nagasa = KBanme Then With MeNamae .ListBox1.AddItem (ListNamae) .ListBox1.List(.ListBox1.ListCount - 1, 1) = i End With End If Else Exit Do End If Loop Until Nagasa <= KBanme Next End Sub Private Sub ListBox1_Click() Dim r As Long With ListBox1 If .ListIndex > -1 Then r = .List(.ListIndex, 1) '選択した名前の行 TextBox6.Value = Worksheets("顧客データ").Cells(r, 3) 'カタカナ名 TextBox2.Value = Worksheets("顧客データ").Cells(r, 5) '漢字名 TextBox3.Value = Worksheets("顧客データ").Cells(r, 7) '住所 TextBox4.Value = Worksheets("顧客データ").Cells(r, 1) '電話番号 TextBox5.Value = Worksheets("顧客データ").Cells(r, 2) '顧客番号 End If End With End Sub Private Sub CommandButton3_Click() 'クリックすると Worksheets("検索").Cells(, 2) ’このシートの(G2)に上記の電話番号が入力される End Sub
- ベストアンサー
- Visual Basic
- 検索マクロ
下記のマクロは、検索文字でシートを検索し、そのセルアドレス情報を シートを追加して表示する機能ですが、ＢＯＯＫ全体に検索し、シート名を含めて表示するには、ｘｘｘｘのところをどのように変更すればいいか。よろしくお願いします。 Sub kennsaku_Macro1() Dim ret Dim r As Range Dim adr As String Dim cnt As Long Dim psw As Boolean Dim mySht, adSht, ws As Worksheet Set mySht = ActiveSheet ret = Application.InputBox("検索文字列を入力してください") If TypeName(ret) <> "Boolean" Then With mySht.Cells Set r = .Find(ret, LookIn:=xlValues, lookat:=xlPart) If Not r Is Nothing Then adr = r.Address cnt = 2 '2行目から表示 xxxxxxxxxxxxx For Each ws In Worksheets If ws.Name = "検索結果" & ret Then psw = True Exit For End If Next ws If psw Then Set adSht = ws adSht.Cells.ClearContents Else Set adSht = Worksheets.Add adSht.Name = "検索結果" & ret End If adSht.Cells(cnt, 1).Value = r.Value adSht.Cells(cnt, 2).Value = xxxx 'シート名 adSht.Cells(cnt, 3).Value = adr Do Set r = .FindNext(r) If r.Address = adr Then Exit Do Else cnt = cnt + 1 adSht.Cells(cnt, 1).Value = r.Value adSht.Cells(cnt, 2).Value = xxxx 'シート名 adSht.Cells(cnt, 3).Value = r.Address End If Loop End If End With End If adSht.Cells(1, 1).Value = "項目" adSht.Cells(1, 2).Value = "シート名" adSht.Cells(1, 3).Value = "セルアドレス" mySht.Activate End Sub
- ベストアンサー
- オフィス系ソフト
お礼
教えていただいた通りに入力してみたところ、繰り返すことなく動きました。 回答ありがとうございました。