VBAの効率化

Question

VBAの効率化(というより基本的な書き方？)についての質問です。
以前作成したコードを再度流用することとなり、知識0の状態で作っていた酷い有様のコードを
ちょっとはマシな形にしようと修正作業を行っています。
内容としては
ブックAAAの特定の行に○がついていれば同じ行のデータをブックBBBへコピーする
というものです。※○は1～100行の中の1行にしか存在しません。
以前作成したものが↓

For B = 1 to 100
    If Workbooks(AAA).Worksheets("シート1").Cells(B, 2).Value = "○" Then
        Workbooks(AAA).Worksheets("シート1").Activate
        Range(Cells(B, 6), Cells(B, 12)).Copy
        Workbooks(BBB).Worksheets("シート1").Activate
        Range("AO12:AU12").Select
        Selection.PasteSpecial Paste:=xlPasteValues
    End If
Next B

今回修正を行ったものが↓

Dim tempA(50) As Variant
For B = 1 to 100
    If Workbooks(AAA).Worksheets("シート1").Cells(B, 2).Value = "○" Then
        Workbooks(AAA).Worksheets("シート1").Activate
        For A = 6 To 12
            temp(A) = Cells(B, A).Value        
        Next A
        Workbooks(BBB).Worksheets("シート1").Activate
        For A = 6 To 12
            Cells(B, A + 35).Value = temp(A)   
        Next A
        Exit For
    End If
Next B

です。
単純にコピー→ペーストだったものを、一度配列に入れてからまとめてセルに代入する形にしました。
(配列もちょっとおかしい使い方ですが、こうでないと頭の中でこんがらがってしまうのです…)

このような処理を行う場合の方法としては修正後のような方法であっているのでしょうか。
日々勉強しながらコードを書いている為、サイトによって方法がバラバラで自身ではよくわかっていない状況です。。。

【改めて今回の質問内容】
①今回の修正後コードの効率は100点満点で採点すると何点ほどになりますか？(回答者様の主観で結構です)
②修正後コードを改善(またはまったく別の方法へ変更)するとした場合、どのようなやり方が考えられますか？
③「VBAの勉強をするならこのサイト！」のようなものがありましたらお教え下さい。

以上、長文乱文申し訳ございませんが皆様のお力をお貸し頂ければ幸いでございます。

追記
【使用環境】
Windows 7 Pro 32bit
Microsoft Excel 2010

Answer 1

Copy, Paste でクリップボード経由より、直接代入したほうが高速だと思います。

配列を使うなら、バリアント配列を使うと効率的かな。

セル範囲は、バリアント配列に一括して代入できますし、
また、バリアント配列を一括してセル範囲に代入できますので。
（セル範囲をバリアント配列に代入した時は、２次元配列になります。）

    Dim tempA As Variant, tempB As Variant, i As Long

    tempA = Workbooks(AAA).Worksheets("シート1").Range("B1:B10")
    For i = 1 To 10
        If tempA(i, 1) = "○" Then
            tempB = Workbooks(BBB).Worksheets("シート1").Range("F" & i & ":L" & i)
            Workbooks(AAA).Worksheets("シート1").Range("AO12:AU12") = tempB
            Exit For
        End If
    Next

ワークシート関数を使えば、もっとシンプルに記述できます。

    Dim i As Long

    i = WorksheetFunction.Match("○", _
        Workbooks(AAA).Worksheets("シート1").Range("B1:B10"), 0)
    Workbooks(BBB).Worksheets("シート1").Range("AO13:AU13").Value = _
        Workbooks(AAA).Worksheets("シート1").Range("F" & i & ":L" & i).Value

どちらが高速なのかは、分かりませんが、下記によるとワークシート関数が一番高速のようです。

Office TANAKA - Excel VBA高速化テクニック[セルを配列に入れる]

Comments

[Alice0225]

ワークシート関数は初耳な単語ですね…調べたいと思います。
バリアント配列に範囲一括代入が出来るのも知りませんでした。
とても勉強になります！

Answer 2

①あくまでコードの評価という視点で、10点(前)→20点(後)
また、少しばかりのアドバイスですが、以下の点を述べておきます。
・変数の宣言を強制した方が良いです(Option Explicit)
・RangeやCells,Worksheetsには、必ず[.]を付けて親(所属)を明確にする
・'Avtivateに頼らない
・For文で1to100としていますが、100は動的に取る方法を考えた方が良い

②
・修正前の状態で、修正をするとしたら

    With Workbooks(AAA).Worksheets("シート1")
        For B = 1 To 100
            If .Cells(B, 2).Value = "○" Then
                .Range(.Cells(B, 6), .Cells(B, 12)).Copy
                With Workbooks(BBB).Worksheets("シート1")
                    .Range("AO" & B).PasteSpecial Paste:=xlPasteValues
                End With
                Application.CutCopyMode = False 'コピー状態を終了
                Exit For
            End If
        Next B
    End With

・修正後の状態で、修正するとしたら

Private Sub Sample1()
    
    Dim ShA     As Worksheet
    Dim ShB     As Worksheet
    Dim ValAry  As Variant
    Dim TempAry As Variant
    Dim i       As Long
    Dim Col_T   As Long
    Dim Col_S   As Long
    Dim Col_E   As Long
    
    Set ShA = Workbooks("AAA").Worksheets("シート1")
    Set ShB = Workbooks("BBB").Worksheets("シート1")
    
    With ShA
        Col_T = 2
        ValAry = .Range(.Cells(1, Col_T), .Cells(100, Col_T)).Value
    End With
    
    For i = LBound(ValAry, 1) To UBound(ValAry, 1)
        If ValAry(i, 1) = "○" Then
            Col_S = 6
            Col_E = 12
            With ShA
                TempAry = .Range(.Cells(i, Col_S), .Cells(i, Col_E)).Value
            End With
            ShB.Cells(i, Col_S).Offset(, 35).Resize(1, UBound(TempAry, 2) - LBound(TempAry, 2) + 1).Value = TempAry
            Exit For
        End If
    Next
    
    Set ShA = Nothing
    Set ShB = Nothing
    
End Sub

・自分でコーディングするとしたら

Private Sub Sample1()
    
    Dim ShA     As Worksheet
    Dim ShB     As Worksheet
    Dim RngA    As Range
    Dim RngB    As Range
    Dim ValAry  As Variant
    Dim i       As Long
    Dim Row_S   As Long
    Dim Row_E   As Long
    Dim Row_T   As Long
    Dim Col_T   As Long
    Dim Col_S   As Long
    Dim Col_E   As Long
    Dim Col_Off As Long
    
    Set ShA = Workbooks("AAA").Worksheets("シート1")
    Set ShB = Workbooks("BBB").Worksheets("シート1")
'    Set ShA = Sheet1
'    Set ShB = Sheet2
    
    'Findは回数を重ねると遅いので、配列を使用する方法を使います。(1万行程度まで大丈夫…なはずです)
    With ShA
        Col_T = 2
        Row_S = 1
        Row_E = 100 '場合によっては動的に取得
        ValAry = .Range(.Cells(Row_S, Col_T), .Cells(Row_E, Col_T)).Value
    End With
    
    For i = LBound(ValAry, 1) To UBound(ValAry, 1)
        If ValAry(i, 1) = "○" Then
            Col_S = 6
            Col_E = 12
            Col_Off = 35
            '配列の要素と、行数が異なる場合に対応して行数調整
            Row_T = Row_S + i - 1
            With ShA
                Set RngA = .Range(.Cells(Row_T, Col_S), .Cells(Row_T, Col_E))
            End With
            With ShB
                Set RngB = .Range(.Cells(Row_T, Col_S), .Cells(Row_T, Col_E)).Offset(, Col_Off)
            End With
            Call RngA.Copy(RngB)
            '値だけで良ければ: RngB.Value = RngA.Value
            Exit For
        End If
    Next
    
    Set RngA = Nothing
    Set RngB = Nothing
    Set ShA = Nothing
    Set ShB = Nothing
    
End Sub

③
自分の場合は、周囲に教えて頂ける方々がいたのですが、
何かに困って調べた時には、よく田中さんのサイトにお世話になったと思います。
http://officetanaka.net/excel/index.htm
困った時に検索して、Hitしていたら優先的に見る、というような感じでした。

④
VBAは軽視されがちですが、奥が深いです。
使いこなせれば良いパートナーとなってくれるはずですので、
頑張ってください。

Comments

[Alice0225]

ご回答ありがとうございます。
ご指摘頂きました
①変数の宣言を強制した方が良いです(Option Explicit)
②RangeやCells,Worksheetsには、必ず[.]を付けて親(所属)を明確にする
③'Avtivateに頼らない
④For文で1to100としていますが、100は動的に取る方法を考えた方が良い
につきましては
①宣言部分に関しては長くなってしまうので省略してコードを記載させて頂きました。
②アドバイス通り修正いたします。
③アドバイス通り修正いたします。
④For文に関しては①と同様長くなるのでコードを省略しております。
　実際にはMaxRowを使用したつくりになっています。

その他ご提示頂いたコードに関しましてもありがとうございました。
知識不足で理解に時間がかかりそうですが勉強しつつ実装・修正にあたりたいと思います！

Answer 3

マクロを流すことでクリップボードの中身を書き換えられてしまうのはあまり好まれませんよね。
その点を改善しようとしたこと自体が評価に値すると思います。
コーディングについては、変数名がわかりにくいところが減点です。
ちょっとしたプログラムのちょっとした変数でも、ポリシーを持って記述したほうが後後のためになりますよ。

改善案・・・というか参考情報のようなものですが、今回のように値のみのコピーでよくて、コピー元とコピー先が同じ並び順でよいのなら、rangeからrangeに値を写す方法が使えます。
また、対象行の検索方法についても選択肢のひとつとしてFindを使う方法を紹介してみます。

処理速度や使い勝手で使いやすいものを選んでみてください。

    Dim s1 As Worksheet         'コピー元シート
    Dim s2 As Worksheet         'コピー先シート
    
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    
    Dim rngSearch As Range      '検索範囲
    Dim rngFind As Range        '検索結果
    Dim strFirstAdr As String   '最初に見つかった検索結果のアドレス
    
    Dim rngCopyFrom As Range    'コピー元
    Dim rngCopyTo As Range      'コピー先
    Dim intCopyCnt As Integer   'コピー件数
    
    '検索範囲の設定
    'Set rngSearch = s1.Range("B:B")
    Set rngSearch = s1.Range("B1:B100")
    '○を検索
    Set rngFind = rngSearch.Find("○")
    
    If Not (rngFind Is Nothing) Then
    
        strFirstAdr = rngFind.Address
        
        Do
            'コピー件数
            intCopyCnt = intCopyCnt + 1
            'コピー元の範囲設定
            Set rngCopyFrom = s1.Range("F" & CStr(rngFind.Row) & ":L" & CStr(rngFind.Row))
            'コピー先の範囲設定
            Set rngCopyTo = s2.Range("AO" & CStr(rngFind.Row) & ":AU" & CStr(rngFind.Row))
            
            '値のコピー
            rngCopyTo.Value = rngCopyFrom.Value
            
            '次の対象を検索
            Set rngFind = rngSearch.FindNext(rngFind)
            
            If rngFind Is Nothing Then Exit Do
            
        Loop Until rngFind.Address = strFirstAdr
        
    End If

Comments

[Alice0225]

コードのご提示ありがとうございます。
質問欄に書いたものは全体の一部でして、
A1:A5をコピーして別ブックへ貼り付ける　だけでよい場合と
A1,A4,A7,A11,A15をコピーして別ブックへ貼り付ける　様な場合があったりします。
Findやアドレスを使った方法は知りませんでしたので、頂きましたアドバイスを元に今回のコードに適用できるか試してみたいと思います＾＾

Answer 4

VBAマクロなんてもう何年もいじっていないのですっかり忘れていてなんだったか思い出せなかったのですが、ようやく思い出せました。
たくさんのセルを書き換えたりするような場合は画面の更新を停止すれば速くなります。
最初にApplication.ScreenUpdating = Falseとやって画面の更新を停止し、
最後にApplication.ScreenUpdating = Trueとやれば更新を再開します。

Comments

[Alice0225]

ご回答ありがとうございます。
そのあたりの処理は記載してありますので問題ありません。
今回は内部の重要部分コードのみの修正になります。

[catsforepaw]

なるほど、失礼しました。

[Alice0225]

こちらこそ省略省略で書いてしまっていて申し訳ございませんでした…。

Answer 5

印象としてはむしろ改悪されているように思います。
必要ない配列を宣言し(しかもバリアント型)、ループを無駄に多くとっています。
根本的な問題として、質問者様は**「アクティブ状態のシートでなければコピー・貼り付けができない」と思い込んでいませんか？**
セルの操作(セルのコピー)

For B = 1 to 100
    If Workbooks(AAA).Worksheets("シート1").Cells(B, 2).Value = "○" Then
        Workbooks(AAA).Worksheets("シート1").Range(Cells(B, 6), Cells(B, 12)).Copy
        Workbooks(BBB).Worksheets("シート1").Range("AO12:AU12").PasteSpecial Paste:=xlPasteValues
    End If
Next B

一応改善しようとするとこうなりますが、これだとコピー先に上書きされ続けて最後に貼り付けたものしか残らないのでは…？

Comments

[Alice0225]

実行に掛かる時間に関してだけ言えば約6分の1に短縮されていたので、改善されていると思っておりました。
試しに
Workbooks(AName).Worksheets("Sheet1").Range("A1:A6").Copy Workbooks(BName).Worksheets("Sheet1").Range("B1:B6")
を試してみましたが上手く範囲コピーされないのはなぜでしょう？

追記
ちなみに○は1～100行目のどこか1行にしかありませんすみません。

範囲指定が完全に間違っていました…
範囲コピーに関しては問題なさそうです。

[swordone]

改行されているからではないでしょうか？
ひとつづきの命令を複数行に跨がって書くには行継続文字が必要です。

[hatena19]

Workbooks(AAA).Worksheets("シート1").Range(Cells(B, 6), Cells(B, 12))

だと、Cells はアクティブなシートを参照するのでは？
Activateしないなら、

With Workbooks(AAA).Worksheets("シート1")
.Range(.Cells(B, 6), .Cells(B, 12))
End With

かな？

[swordone]

そうでした、そのことを失念していました。