[[20200501171004]]　『別シートへ転記』（はとむぎ）　ページの最後に飛ぶ

『別シートへ転記』（はとむぎ）

VBA勉強中です。
下記は一部抜粋したものですが、なんとかもっと簡単に出来ないものかと
考えています。

 ☆.Range("A" & s) = Range("A" & i)
　この部分以下14行の部分を簡単に表す方法は無いでしょうか？

   With Worksheets("リスト")
     For i = 6 To j
        If Range("D" & i) <> "済" Then
            .Range("A" & s) = Range("A" & i)
            .Range("B" & s) = Range("B" & i)
            .Range("C" & s) = Range("C" & i)
            .Range("D" & s) = Range("E" & i)
            .Range("E" & s) = Range("F" & i)
            .Range("F" & s) = Range("G" & i)
            .Range("G" & s) = Range("I" & i)
            .Range("H" & s) = Range("J" & i)
            .Range("I" & s) = Range("L" & i)
            .Range("J" & s) = Range("M" & i)
            .Range("K" & s) = Range("N" & i)
            .Range("L" & s) = Range("O" & i)
            .Range("M" & s) = Range("Q" & i)
            .Range("N" & s) = Range("S" & i)
            s = s + 1
        End If
     Next i

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 1案
     If Range("D" & i) <> "済" Then
         .Range("A" & s).Resize(, 3).Value = Range("A" & i).Resize(, 3).Value
         .Range("D" & s).Resize(, 3).Value = Range("E" & i).Resize(, 3).Value
         .Range("G" & s).Resize(, 2).Value = Range("I" & i).Resize(, 2).Value
         .Range("I" & s).Resize(, 4).Value = Range("L" & i).Resize(, 4).Value
         .Range("M" & s).Value = Range("Q" & i).Value
         .Range("N" & s).Value = Range("S" & i).Value
         s = s + 1
     End If

 2案
     For i = 6 To j
        If Range("D" & i) <> "済" Then
            For k = 1 To 14
                n = Choose(k, 1, 2, 3, 5, 6, 7, 9, 10, 12, 13, 14, 15, 17, 19)
                .Cells(s, k).Value = Cells(i, n).Value
            Next k
            s = s + 1
        End If
     Next i

（ピンク） 2020/05/01(金) 17:51

ちょっと確認ですが、【標準モジュール】に

   With Worksheets("リスト")
      .Range("A" & s) = Range("A" & i)

みたいに書いたら

 Worksheets("リスト").Range("A" & s).Value = ActiveSheet.Range("A" & i).Value

って書いたことになりますけどそれで大丈夫なんです？

（もこな２） 2020/05/01(金) 18:01

ピンクさん
ありがとうございます。
Chooseの存在は初めて知ったので内容は、今から確認するのですが、
かなり簡素化されていい感じになりそうです。

もこな２様
そのつもりで書いています。
間違った書き方かもしれませんが、思い通りには動いていますよ。
（はとむぎ） 2020/05/01(金) 18:08

＞間違った書き方かもしれませんが、思い通りには動いていますよ。
間違っているというつもりはないですが、個人的にあんまりアクティブ〇〇ありきの書き方はしないのでちょっと気になりました。

また、Valueを直接参照して値貼付の代わりをするやり方を否定するものではないですが、今回のケースでいえば、コピーして、普通に値貼付すれば楽なんじゃないかとおもいました。

    Sub 実験01()
        Const i As Long = 100
        Const s As Long = 2

        Dim tmp As Range
        Dim MyRNG As Range

        With ActiveSheet
            For Each tmp In .Range("D6", .Cells(i, "D"))
                If tmp.Value <> "済" Then
                    If MyRNG Is Nothing Then
                        Set MyRNG = tmp
                    Else
                        Set MyRNG = Union(MyRNG, tmp)
                    End If
                End If
            Next tmp

            If Not MyRNG Is Nothing Then
                Intersect(MyRNG.EntireRow, .Range("A:G,I:J,L:O,Q:Q,S:S")).Copy
                Worksheets("リスト").Cells(s, "A").PasteSpecial Paste:=xlPasteValues
            End If
        End With

    End Sub

（もこな２） 2020/05/01(金) 20:13

失礼。こちらの方が見やすいかも。

    Sub 実験01()
        Const i As Long = 100
        Const s As Long = 2

        Dim srcSH As Worksheet
        Dim tmp As Range
        Dim MyRNG As Range

        Set srcSH = ActiveSheet

        For Each tmp In srcSH.Range("D6", srcSH.Cells(i, "D"))
            If tmp.Value <> "済" Then
                If MyRNG Is Nothing Then
                    Set MyRNG = tmp
                Else
                    Set MyRNG = Union(MyRNG, tmp)
                End If
            End If
        Next tmp

        If Not MyRNG Is Nothing Then
            Intersect(MyRNG.EntireRow, srcSH.Range("A:G,I:J,L:O,Q:Q,S:S")).Copy
            Worksheets("リスト").Cells(s, "A").PasteSpecial Paste:=xlPasteValues
        End If

    End Sub

（もこな２） 2020/05/01(金) 20:19

わたしなら、オートフィルタかフィルタオプションを使います。

（マナ） 2020/05/01(金) 21:24

例えば、こんな感じです

    With Range("A5:S" & j)
        .AutoFilter 4, "<>済"
        If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Intersect(.Offset(1), Range("A:C,E:G,I:J,L:O,Q:Q,S:S")).Copy
            Worksheets("リスト").Range("A" & s).PasteSpecial xlPasteValues
        End If
        .AutoFilter
    End With

（マナ） 2020/05/01(金) 21:50

コメント返信：

[ 一覧(最新更新順) ]

[[20200501171004]] 『別シートへ転記』（はとむぎ） ページの最後に飛ぶ

[[20200501171004]]　『別シートへ転記』（はとむぎ）　ページの最後に飛ぶ