見守り電球またはGPS端末が特価中!

いつもお世話になっております。
配列について教えてください。
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

A 回答 (11件中1~10件)

こんにちは!



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
    • good
    • 1
この回答へのお礼

助かりました

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

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

#9です。

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

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

条件一致95% デモデータ 1000行を Timerで確認
#6= 0.0234375
#9= 0.03515625

条件は、#2の補足にあるように変えて検証しました。
    • good
    • 0
この回答へのお礼

助かりました

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

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

こんにちは



よこからですが・・・

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

イマイチ把握ができていませんけれど、すでにご指摘のある、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
    • good
    • 0
この回答へのお礼

ありがとう

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

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

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


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

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
    • good
    • 0

No.7です。



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

ちょっと修正

指定しているのってsh1の列番号であってsh2の列番号ではないのではないのかな?
    • good
    • 0

初級者的な疑問です。



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

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


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

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

でいいんじゃないかと思います。
    • good
    • 0
この回答へのお礼

ありがとう

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

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

No.2です。



あ”、代入先ってE列が抜けてたのですね。(もぅ~老眼は嫌ですねぇ)

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

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

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

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)

の1行に纏めるとか?
    • good
    • 0
この回答へのお礼

うーん・・・

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

>・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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング