VBA配列 列を指定する方法について

いつもお世話になっております。
配列について教えてください。
EXCELは2016を使用しています。

大元のシート：sheet1　項目行：2
貼付けいシート：sheet2　項目行：2
sheet1の3行目からB列最終行までで
B列の最後が "W"、C列の最後が "port" になっているものを
↓の列通りにsheet2に貼り付けたいです。
下記のコードでできることはできたんですが、完了するまでに時間がかかり、100行くらいしかないものでも20秒以上かかります。
もっと早くできる方法はありますでしょうか？
Rangeを使えば早いのかと思いましたが、自分じゃかけず、、、
アドバイスよろしくお願いします。

sheet2　列　=　sheet1　列
A列　　　　＝　C列
B列　　　　＝　A列
C列　　　　＝　B列
D列　　 　＝ AA列
F列　　　　＝　G列

sheet1　
Sub sample()
Application.ScreenUpdating = False

Dim i As Long, k As Long
Dim cnt As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim myRng As Range
Dim myAry1, myAry2

Set sh1 = Sheets("sheet1") '大元のデータ
myAry2 = Array(3, 1, 2, 27, 7) 'C,A,B,AA,G列

Set sh2 = Sheets("sheet2") '出力先
myAry1 = Array(1, 2, 3, 4, 6) 'A,B,C,D,F列

cnt = 3 '貼り付け行

With sh2
For i = 3 To sh1.Cells(Rows.Count, "B").End(xlUp).row 'A3～最終行まで

If sh1.Cells(i, 2) Like "*w" Or sh2.Cells(i, 3) Like "*port" Then
For k = 0 To UBound(myAry1)
.Cells(cnt, myAry2(k)).Value = sh1.Cells(i, myAry1(k)).Value '★★
Next k
cnt = cnt + 1
End If

Next i
End With

MsgBox "完了しました"
Application.ScreenUpdating = True
End Sub

No.11 回答者： Qchan1962 回答日時： 2020/07/17 13:19

#9です。

よく読まず、失礼しました。
＃６のRange(.Cells(3, "A"), .Cells(lastRow, "F")) = myR1
勉強になりました。

配列に読み込む時に操作し配列に合わせて出力範囲を設定する（＃６）
書き出した後操作する（＃９）
当然、（＃６）の方が処理は早いと思います。基本でした。。

条件一致95％　デモデータ 1000行を　Timerで確認
＃６＝ 0.0234375
＃９＝ 0.03515625

条件は、＃２の補足にあるように変えて検証しました。

この回答へのお礼

検証までしてくださってありがとうございます。
こちらも私が書いたものよりずっと早くて感動しました。
勉強にもなって助かりました！
アドバイスありがとうございました！！

お礼日時：2020/07/17 13:46

No.10 回答者： fujillin 回答日時： 2020/07/17 12:17

こんにちは

よこからですが・・・

＞下記のコードでできることはできたんですが、～
とあるので、コードを正と考えた方が良さそうなのですが、どうも疑問なので・・・

イマイチ把握ができていませんけれど、すでにご指摘のある、portの条件判定はsheet1で行うものとして、列の対応関係はご提示のコードの内容は間違いで説明文にある方が正と勝手に解釈しました。

処理に時間がかかる原因となりやすいのは、セルへのアクセス回数（読み書き）です。
データをまとめて配列に取り込んで、配列内で処理をしておいて、まとめて書き出すのが一番速いと思いますが、処理対象のセルが飛び飛びのようなので、少し違う方法で考えてみました。
エクセルの機能を利用する方法にしていますので、ご提示のコードとは違うアプローチです。
具体的には、作業列に抽出用関数を設定し、これを用いてオートフィルタで抽出して、まとめてコピペするという方法です。

少しは速くなるのではないかと想像していますが、同じようなデータで試してみないと何とも言えません。
（上で紹介した、メモリ内で計算してしまう方法が一番速いとは思いますが…）

※ 値の転記はひとまずコピペにしてあります。
　 コピペではまずい場合には、「値をペースト」に変えれば対応できると思います。

以下、ご参考までに。

Sub Sample_11771769()
Dim sh As Worksheet
Dim nR As Long, nC As Long

Const f = "=IF((RIGHT(A3,1)=""w"")+(RIGHT(C3,4)=""port""),1,0)"
Set sh = Worksheets("sheet2")

With Worksheets("sheet1")

nR = .Cells(Rows.Count, 2).End(xlUp).Row - 2
nC = .UsedRange.Columns.Count + 1
.Cells(3, nC).Resize(nR).FormulaLocal = f
.Columns(nC).AutoFilter 1, 1

.Range("C3").Resize(nR).Copy sh.Range("A3")
.Range("A3").Resize(nR).Copy sh.Range("B3")
.Range("B3").Resize(nR).Copy sh.Range("C3")
.Range("AA3").Resize(nR).Copy sh.Range("D3")
.Range("G3").Resize(nR).Copy sh.Range("F3")

.Columns(nC).AutoFilter
.Columns(nC).Clear

End With
MsgBox "完了"
End Sub

この回答へのお礼

初めはコピーでやってたんですが
データが増えるとくるくるとかたまってしまってて。
でもきっと一番確実ですよね。
アドバイスありがとうございました！

お礼日時：2020/07/17 13:43

No.9 回答者： Qchan1962 回答日時： 2020/07/17 12:12

こんにちは、横から失礼します。

テスト環境作るのが、時間がなく、、すみません。
ご質問の掲示コードを少し改造してみましたが、汎用性には欠けます。
早くなるか検証していませんが、、、どうでしょう？

Sub sample()
Dim i As Long, k As Long
Dim cnt As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim myAry1 As Variant, myAry2 As Variant
Dim mvCol As Variant
　　Application.ScreenUpdating = False
　　Set sh1 = Sheets("sheet1")　　'大元のデータ
　　myAry2 = Array(3, 1, 2, 27, 7)　　'C,A,B,AA,G列
　　Set sh2 = Sheets("sheet2")　　'出力先
　　With sh1
　　　　i = Application.Max(Application.CountIf(.Range("B:B"), "*w"), Application.CountIf(.Range("C:C"), "*port"))
　　　　ReDim myAry1(i, 4)
　　　　For i = 3 To .Cells(Rows.Count, "B").End(xlUp).Row　　'A3～最終行まで
　　　　　　If .Cells(i, 2) Like "*w" Or .Cells(i, 3) Like "*port" Then
　　　　　　　　For k = 0 To UBound(myAry2)
　　　　　　　　　　myAry1(cnt, k) = .Cells(i, myAry2(k))　　'★★
　　　　　　　　Next k
　　　　　　　　cnt = cnt + 1
　　　　　　End If
　　　　Next
　　End With
　　With sh2
　　　　mvCol = .Range("E3:E" & .Cells(Rows.Count, "E").End(xlUp).Row)
　　　　.Range("A3").Resize(UBound(myAry1, 1) + 1, UBound(myAry1, 2) + 1) = myAry1
　　　　.Range("F3:F" & .Cells(Rows.Count, "E").End(xlUp).Row).Value = .Range("E3:E" & .Cells(Rows.Count, "E").End(xlUp).Row).Value
　　　　.Range("E3").Resize(UBound(mvCol)) = mvCol
　　End With
　　　　MsgBox "完了しました"
　　Application.ScreenUpdating = True
End Sub

No.8 回答者： めぐみん_ 回答日時： 2020/07/17 11:03

No.7です。

＞指定しているのってsh1であってsh2の列ではないのではないのかな？

ちょっと修正

指定しているのってsh1の列番号であってsh2の列番号ではないのではないのかな？

No.7 回答者： めぐみん_ 回答日時： 2020/07/17 11:00

初級者的な疑問です。

AdvancedFilterでsh2のＥ列ってどこで回避条件を持たせているのか興味津々。
最近使ってないから忘れてしまったけど、フィルタをかけた範囲のうち抽出されたデータがCopyToRangeに張り付くけど、指定しているのってsh1であってsh2の列ではないのではないのかな？（老眼で見落としている）

No.6 ベストアンサー 回答者： tom04 回答日時： 2020/07/17 10:51

こんにちは！

Sheet2に吐き出すのは一つ一つではなく、
一旦配列に格納し最後に一気に吐き出してみてはどうでしょうか？

一例です。

Sub Sample1()
　Dim i As Long, k As Long
　Dim lastRow As Long, cnt As Long
　Dim wS As Worksheet
　Dim myR, myR1, myAry

　　Set wS = Worksheets("Sheet1")
　　myAry = Array(3, 1, 2, 27, 7)
　　　With Worksheets("Sheet2")
　　　　'//▼Sheet2のA～D列・F列のデータを一旦消去//
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 2 Then
　　　　　　Union(Range(.Cells(3, "A"), .Cells(lastRow, "D")), Range(.Cells(3, "F"), .Cells(lastRow, "F"))).ClearContents '//★//
　　　　　End If

　　　　'//▼ココから操作//
　　　　lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
　　　　　myR = Range(wS.Cells(3, "A"), wS.Cells(lastRow, "AA"))
　　　　　myR1 = Range(.Cells(3, "A"), .Cells(lastRow, "F")) '//←Sheet2の範囲を広めに指定しておく//
　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　If myR(i, 2) Like "*W" Or myR(i, 2) Like "*port" Then
　　　　　　　　cnt = cnt + 1
　　　　　　　　　For k = 0 To UBound(myAry)
　　　　　　　　　　If k < 4 Then
　　　　　　　　　　　myR1(cnt, k + 1) = myR(i, myAry(k))
　　　　　　　　　　Else
　　　　　　　　　　　myR1(cnt, 6) = myR(i, myAry(k))
　　　　　　　　　　End If
　　　　　　　　　Next k
　　　　　　　End If
　　　　　　Next i
　　　　　　'//▼Sheet2に一気に吐き出す//
　　　　　　Range(.Cells(3, "A"), .Cells(lastRow, "F")) = myR1
　　　　　　　.Activate
　　　End With
　　　　MsgBox "完了"
End Sub

※　Sheet2のE列に万一データがある場合、そのデータに手を付けないようにしています。
もし、Sheet2のE列もデータ消去してよいのであれば、「★」の行を
＞Range(.Cells(3, "A"), .Cells(lastRow, "F")).ClearContents

に変更してみてください。m(_ _)m

この回答へのお礼

おおおぉぉっ！！
めっちゃ神と呼びたい！ありがとうございます！
転記が一瞬で済んで、Range にした方が早いと思いつつ自分じゃどうしても解決できなかったので
とても助かりました！！
ありがとうございました！！！

お礼日時：2020/07/17 13:37

No.5 回答者： d-q-t-p 回答日時： 2020/07/17 10:35

Criteria用のセル範囲をひとまず Sheet1の「G2:G3」としましたが

空いているところならどこでもいいです。

No.4 回答者： d-q-t-p 回答日時： 2020/07/17 10:34

Sheet1と Sheet2の項目名さえ合っているなら

Dim i As Long, lr As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim myAry2

Set sh1 = Sheets("sheet1") '大元のデータ
myAry2 = Array(3, 1, 2, 27, 7) 'C,A,B,AA,G列
Set sh2 = Sheets("sheet2") '出力先

Application.ScreenUpdating = False
With sh1
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("G3").Formula = "=COUNTIF(B3,""*w"")*COUNTIF(C3,""*port"")"
End With

With sh2
For i = 0 To 4
sh1.Range("A2:F" & lr).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=sh1.Range("G2:G3"), _
CopyToRange:=.Cells(2, myAry2(i))
Next i
End With
Application.ScreenUpdating = True

でいいんじゃないかと思います。

この回答へのお礼

項目名が違っているので適用できないんですが
こういったやり方もあるのかと勉強になりました！
アドバイスありがとうございました！

お礼日時：2020/07/17 13:33

No.3 回答者： めぐみん_ 回答日時： 2020/07/17 08:53

No.2です。

あ”、代入先ってＥ列が抜けてたのですね。（もぅ～老眼は嫌ですねぇ）

手段としては問題ない手法なのですが、時間がかかるってのが。。。

画面描画は止めているようですがもし数式がその中にあるのであれば、
https://sites.google.com/site/compositiosystemae …

最初に計算を手動にして終わったら自動に戻すので効果があるかどうか。

No.2 回答者： めぐみん_ 回答日時： 2020/07/17 08:16

No.1の疑問をコードにすると、

If sh1.Cells(i, 2) Like "*w" And sh1.Cells(i, 3) Like "*port" Then

ではないのかな？

・B列の最後が "W"、『且つ』C列の最後が "port" になっているものを

であるならね。

・B列の最後が "W"、『又は』C列の最後が "port" になっているものを

なら質問文のコードになるけどシート変数の指定が sh2 ⇒ sh1 だと思うのだけど。

For k = 0 To UBound(myAry1)
.Cells(cnt, myAry2(k)).Value = sh1.Cells(i, myAry1(k)).Value '★★
Next k

については列の配列をなくして

.Cells(cnt, 1).Resize(, 5).Value = Array(sh1.Cells(i, "C").Value, sh1.Cells(i, "A").Value, sh1.Cells(i, "B").Value, sh1.Cells(i, "AA").Value, sh1.Cells(i, "G").Value)

の１行に纏めるとか？

この回答へのお礼

アドバイスありがとうございます。
修正する前のものを張り付けてしまい、混乱させて申し訳ありません。

>・B列の最後が "W"、『又は』C列の最後が "port" になっているものを出したくて

→If sh1.Cells(i, 2) Like "*w" Or sh1.Cells(i, 3) Like "*port" Then
になります。

>.Cells(cnt, 1).Resize(, 5).Value = Array(sh1.Cells(i, "C").Value, sh1.Cells(i, "A").Value, sh1.Cells(i, "B").Value, sh1.Cells(i, "AA").Value, sh1.Cells(i, "G").Value)

貼り付け先がA～DとF列なのと、ものによっては貼り付け位置が変わるのでArrayにしたんですが
やはり難しいんですかね...。

お礼日時：2020/07/17 08:41