- ベストアンサー
VBAの速度向上について
mitarashiの回答
- mitarashi
- ベストアンサー率59% (574/965)
#3です。 AutoFilter法 #3と同じ条件で、57秒かかりました。この位なら我慢できない事はないですね。ご参考まで。 ※もっと高速化できるよというところがあればご指摘下さい。 Sub autoFilterMethod() Dim myTable As Range, dataArea As Range Dim srcColumn As Variant Dim startTime As Long Dim refTable As Variant Dim i As Long Dim destRange As Range startTime = GetTickCount Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'Sheet1!$A$1:$O$123428 2013年頃取り込んだ郵便番号辞書 12万行、3列目が郵便番号 Set myTable = Sheets("Sheet1").Range("A1").CurrentRegion Set dataArea = Intersect(myTable, myTable.Offset(1, 0)) 'コピー先 Set destRange = Sheets("Sheet5").Range("A1") '抽出するキーのリスト 1000行 refTable = Sheets("Sheet4").Range("A1").CurrentRegion.Value For i = 1 To UBound(refTable, 1) myTable.AutoFilter Field:=3, Criteria1:=refTable(i, 1) dataArea.SpecialCells(Type:=xlCellTypeVisible).Copy Destination:=destRange Set destRange = destRange.Offset(1, 0) Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = False Debug.Print CStr(GetTickCount - startTime) End Sub
関連するQ&A
- エクセルVBAについての質問です。
エクセルＶＢＡについての質問です。 動作環境は OS:WINDOWS XP エクセル２００３ です。 今、Book1.xlsというエクセルファイルがあります。 このファイルの中に、【sheet1】,【sheet2】,【sheet3】の３つのシートが存在しています。 【sheet1】および【sheet2】には、Ａ列＝ユニーク番号、Ｂ列＝データ１、Ｃ列＝データ２・・・・ｎ列＝データｎの値が約1500行（各行で、データの値は異なります。）入っています。 この【sheet1】と【sheet2】のデータの内容を照合して【sheet3】にその結果を反映（TRUEまたはFALSE）します。 仮に【sheet3】のあるセル（仮にD3）の値がTRUEとなったら、【sheet1】のセル（D3）の値を【sheet3】のセル（D3)に代入する。 逆に【sheet3】のあるセルの値がFALSEとなったら、そのセルはFLASEのままにする。プログラムは以下の様にしたのですが、全てを処理するまでに相当時間がかかっています。 VBAのプログラムは今回初めて書いたので、プログラムが悪いのか、プログラムの思想が悪いのかがわかりません。 どなたかご教授していただけませんか？多分、コードの書き方もキレイではないと思います（悲） Private Sub データ照合ボタン_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i As Long Dim area As Range Dim A As Variant Dim WrkRange As String '----シート（１）とシート（２）の各セルの値を比較---- With Sheets("sheet1") WrkRow = .Cells(Rows.Count, 3).End(xlUp).Row End With Sheets("sheet3").Select For i = 12 To WrkRow WrkRange = Range("C" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" WrkRange = Range("D" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" '・ '・ '・ Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("C" & i).Select Selection.Copy Range("C" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("C" & i) = True Then Sheets("sheet1").Select Range("C" & i).Copy Sheets("sheet3").Select Range("C" & i).Select ActiveSheet.Paste Else: End If Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("D" & i).Select Selection.Copy Range("D" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("D" & i) = True Then Sheets("sheet1").Select Range("D" & i).Copy Sheets("sheet3").Select Range("D" & i).Select ActiveSheet.Paste Else: End If Next i '・ '・ '・ End Sub
- ベストアンサー
- Visual Basic
- VBAで空欄にデータに表示
エクセルVBAのIFを使って、シートaのA列に値があって、B列が空欄の場合のみ、空欄のセルにシートbの値を表示させたいです。 上手くできませんでしたので、教えてください。 Sub Do文2() Dim i As Integer i = 1 If Worksheets("a").Cells(i, 2) = "" Then Do While Worksheets("a").Cells(i, 1) <> "" Worksheets("a").Cells(i, 2) = Worksheets("b").Cells(1, 1) i = i + 1 Loop End If End Sub
- ベストアンサー
- Windows Vista
- EXCEL2003 VBAで動作が速くなるようにマクロ記述したいのです
EXCEL2003 VBAで動作が速くなるようにマクロ記述したいのですが、どのように行えばいいのでしょうか？ Sheet1のA1からA300まで、関数によって計算されたデータが格納されています。 そのA1からA300の値（関数の計算結果のみ）を、コマンドボタンをクリックした時にSheet2のA1からA300にコピーしています。 コマンドボタンをクリックする度に、Sheet1のA1からA300までの値を、Sheet2に列を変えてコピーし、値を蓄積する方法を取っています。 以下のマクロを記述して走らせてみましたが、動作が遅いのが気になります。 コピーして貼り付けている動作が遅くなっているのでしょうか？ もう少し早くなる方法はありますでしょうか？ よろしくお願いします。 Sub CommandButton1_Click1() Dim I Dim N Worksheets("sheet1").Range("F1").Value = Range("F1").Value + 1 N = Worksheets("sheet1").Range("F1").Value For I = 1 To 300 Application.ScreenUpdating = False Worksheets("sheet1").Cells(I, 1).Copy Worksheets("sheet2").Cells(I, N).PasteSpecial Paste:=xlValues Application.ScreenUpdating = True Next End Sub
- ベストアンサー
- その他MS Office製品
- VBAの複数条件分岐について
VBAで下記の構文を使用してシート１にある表より 条件に合致するもののみシート２に抽出するようにしています。 現在はシート１のE２セルの値がシート１のB列の値と比較して 該当するものを抽出しています。 この条件が、 シート１のE１のセルの値が２０より小さい場合、 かつE2のセルの値がシート１のB列の値と比較して該当するものを シート１に貼り付け、 シート１のE1のセルの値が20以上の場合、 かつE２のセルの値がシート１のD列の値と比較して該当するものを シート１に貼り付ける というような条件に変えたいのですが どのように変更したらよろしいのでしょうか。 よろしくご教授下さい。 ちなみに現在使用している構文です。 これもきれいな構文かはわからないのですが・・・ Sub test() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") k = 1 sh2.Cells(k, "B") = sh1.Cells(1, "A") sh2.Cells(k, "C") = sh1.Cells(1, "B") k = k + 1 d = sh1.Range("A65536").End(xlUp).Row For i = 2 To d If sh1.Cells(i, "B") <= sh1.Range("E2") Then sh2.Cells(k, "B") = sh1.Cells(i, "A") sh2.Cells(k, "C") = sh1.Cells(i, "B") k = k + 1 End If Next i sh2.Activate End Sub
- ベストアンサー
- オフィス系ソフト
- VLOOKUP関数と同じことをVBAでおこなうには
初めまして、当方ＶＢＡの素人です。よろしくお願いします。 同じような質問で、このようなVBAを見つけました。 Sub Macro1() For n = 2 To 5 '処理するSheet2の行数範囲 a = Sheets("Sheet2").Cells(n, 1) 'aにA列の値を代入 For m = 2 To 5 '検索するSheet1の行数範囲 If Sheets("Sheet1").Cells(m, 1) = a Then 'Sheet2のA列の値とSheet1のA列が一致した場合 v = Sheets("Sheet1").Cells(m, 2) 'vにB列の値を代入 Sheets("Sheet2").Cells(n, 2).Value = v 'Sheet2のB列に値を入力 Exit For '値が見つかったのでForを終了 End If Next Next End Sub このVBAではSheet2での検索、入力が列になるのですが、列でなく、行でできないでしょうか。できればSheet1のB列の値をSheet２の１行で検索、Sheet２の２行に入力されるだけではなく、Sheet1のＣ列の値をSheet３の１行で検索、Sheet３の２行に入力されるようにしたいと思います。 解る方、よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- VBAについて
はじめまして、以下のVBAについて質問させてください。 A列にデータの個数だけ連番を振りたくて、以下のVBAを入力しました。 連番を振るシートは複数あり、そのシートによってデータの個数は異なります。 しかし、以下のVBAだと最初のシートの個数に応じて、後のシートの連番も振られてしまいます。データの個数に応じてシートごとに連番を振るには、どうすればよいのでしょうか…？！どうか迷える子羊をお助け下さい(T_T) '一番はじめのシートを選択 Sheet "一番".Select 'Ａ列に連番を振る Dim sh As Variant For sh = 3 To Worksheets.Count Dim number As Integer Dim 行2 As Long number = 1 '2行目～最終行までループ For 行2 = 3 To Cells(Rows.Count, 2).End(xlUp).Row Worksheets(sh).Cells(行2, 1) = number number = number + 1 Next 行2 Next sh
- ベストアンサー
- Excel（エクセル）
- 【エクセル】VBAでハイパーリンクそうさ
VBAでハイパーリンクのマクロを組んでいます。 A列にホームページ名が50行（シートによってまちまち）くらい並んでいて、 B列に、それに対応するURLが記入されています。B列は空白のところがちらほ らあります。 A列に、A列の表示（ホームぺジ名）のまま、B列のURLでハイパーリンクを張りたい です。リンクは貼れたんですが、ホームページ名がどうやれば表示できるかわかり ません。教えてくださいお願いします。 ダメダメですが、一応自分で書けたところまでを載せておきます。 Sub ハイパーリンク() Dim i As Integer Dim j As Integer j = 50 For i = 1 To j Sheets("Sheet1").Select Cells(i , 1).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ Cells(i , 2), TextToDisplay:="" Next i End Sub としました。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでのエラーの対処方法
よろしくお願いします。 A1：1 B1:あ A2：2 B2：い A3：3 B3：う と書いてあるまとめシートと、1、2、3というシートがあるとします。 シート1のA1セルに「あ」、シート2のA1セルに「い」、シート3のA1セルに「う」と書き込まれるように、まとめA列の文字列からシート名を呼び出して書き込むようにVBAを組んでいます。 Dim sht_n As Variant Dim sht_c As Integer i = 7 sht_n = Worksheets("まとめ").Index sht_c = ThisWorkbook.Sheets.Count For sht_n = sht_n + 1 To sht_c Step 1 If Cells(i, 1).Value = "" Then i = i + 1 Else wb = Cells(i, 1).Value Worksheets("まとめ").Cells(i,2).Select Selection.Copy ThisWorkbook.Worksheets(wb).Activate Range("A1").Select Selection.PasteSpecial Paste:=xlValues こんな感じ。 下手なのは分かってます。あと、現在使っているものから書き出しているので間違えてる部分もあるかもしれません。 この状態だと、シート1がない場合にはエラーが出てしまって、そこで終わってしまいます。 まとめシートが空欄の場合はエラーを回避しているのですが、シートがない場合の回避方法が分かりません。 On Error Resume Nextは使わずに、シートがない場合にエラーを回避する方法はありますでしょうか。 分かるかた、よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- VBAで複数の行のナンバーを取得し、その行の列の値を参照して値を入れる
下記のことをしたいのですが、調べてもわかりません。 どなたか教えてください。 よろしくお願いします。 内容： エクセルシートのA列の値が11である行ナンバーを取得（複数ある可能性があります）する。 その行のE列（5列目）の値と他のテーブルの値を参照して所定の値をA列の値が11である行のE列（5列目）に返す。 以下のVBAを書いてみましたがうまくいきません。 ----------------------------------------------------------------- Dim ROWCOUNT As Integer Dim row_array() As Variant Dim i As Integer '全行数を取得 ROWCOUNT=Worksheets("sheet1").Range("A1",Range("A65536").End(xlUp)).Count For i = 1 To ROWCOUNT If Cells(i, 1).Value = 11 Then Cells(i,1).Offset(0,5).Value=WorksheetFunction.VLookup(Cells(i, 1).Offset(0, 5).Value, Worksheets("sheet2").Range("A1:H1786"), 3, False) End If Next I
- ベストアンサー
- その他（プログラミング・開発）
- VBAの操作
↓の事を行いていのでうまくいきません。 アドバイスをお願いできませんか? 変更前(Sheet1); (A列) (B列) 1 ABC010 Data_010 2 ABC020 (同上) 'B1-B2は結合セル 3 ABC030 Data_020 4 ABC040 (同上) 'B3-B4は結合セル . . 変更後(Sheet2); (A列) (B列) 1 ABC010 "OK" 2 ABC020 "OK" 3 Data_010 "Comp" '追加行 4 ABC030 "OK" 5 ABC040 "OK" 6 Data_020 "Comp" '追加行 . . Sheet1(B列)に値があれば、 Sheet2(A列)に結合セルの単位で値をコピーする。 Sheet2(B列)には"OK"コメント その都度、必ず最後に行追加して結合セルの値、"Comp"コメントをコピーする. 現象は毎行、追加行が挿入されてしまいます。 Sub testVBA() Dim i Worksheets("Sheet1").Range("A:B").Copy With Worksheets("Sheet2") .Range("A1").PasteSpecial For i = 1 To 1000 If .Cells(i, 2) <> "" Then .Cells(i + 1, 1) = .Cells(i, 2) .Cells(i + 1, 2) = "Comp" .Cells(i, 2) = "OK" End If Next i End With End Sub
- ベストアンサー
- Visual Basic