[[20190215111543]]　『マクロ　コピー貼り付けと重複データの一括処理に』（エイワン）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『マクロ　コピー貼り付けと重複データの一括処理について』（エイワン）

　下記のようなコードがあります。この２つのコードを一括して処理したいのです。
　現在、処理ができていますが、どうしてもコピーの段階で次ぎに上げたことができずにいます。お教え願えませんか。

やりたいこと

　sheet1にA列だけにデータがあれば、その全ての行はコピー貼り付けせず、A列を含めて、全ての列にデータがあるものだけ、コピー貼り付けする。
このようにコピー貼り付けしたいのでが、コードの書き方がわからず困っています。ご教授お願いできませんか。

Sub コピー貼り付けつけ() 'コピー貼り付けつけのコード

'A列だけにデータがあれば、その全ての行はコピー貼り付けせず、その他の行のみコピー貼り付けする。(現在できていない状態)

Dim lastRow As Long

Dim 重複データを一括削除する, myRng As Range

 For i = 2 To 最終行番号
      N = Application.WorksheetFunction.CountA(Range("A" & i & ":O" & i))
     MsgBox N

      If N < 15 Then '(貼り付けない。15の時のみこの行を貼り付ける。）

   End If
   Next i

'Sheet1のA3から最終行までをコピー

With Sheets("sheet1")
.Range("A3:O" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy
End With

'Sheet2のA列の最終行の次の行に貼付け

Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial

Application.CutCopyMode = False

 '重複データを一括削除する

lastRow = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRow - 1

If WorksheetFunction.CountIf(Range(Cells(i + 1, "O"), Cells(lastRow, "O")), Cells(i, "O")) > 0 Then
If myRng Is Nothing Then
Set myRng = Cells(i, "O")
Else

Set myRng = Union(myRng, Cells(i, "O"))

End If
End If
Next i

If Not myRng Is Nothing Then
myRng.EntireRow.Delete

End If

End Sub

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

---

インデントついてないので見づらいし、もとのトピックまで読み込んでないのでわかりませんが、結局こういうことがやりたいのでは？
（コンパイルエラーにならないことくらいしかチェックしてないので、ミスってたらごめんなさい）

    Sub さんぷる()
        Dim コピー対象 As Range
        Dim i As Long

        '「Sheet1」の操作
        With Worksheets("sheet1")
            '元データ（セル範囲）の定義（2行目からなので、最終行から1引いた分まで行を拡張）
            With .Range("A2:O2").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row - 1)
                For i = 1 To .Rows.Count '【セル範囲】の１行目から最終行までループ

                    '▼【セル範囲】の該当行のデータ数を数えて全部埋まっているか判定する
                    If Application.WorksheetFunction.CountA(.Rows(i)) = 15 Then

                        '条件を満たす行があれば、コピー対象として覚えておく
                        If コピー対象 Is Nothing Then
                            Set コピー対象 = .Rows(i)
                        Else
                            Set コピー対象 = Union(コピー対象, .Rows(i))
                        End If

                    End If
                Next
            End With
        End With

        '▼コピー対象として覚えたセル範囲がなければ終了
        If コピー対象 Is Nothing Then Exit Sub

        '「Sheet2」の操作
        With Worksheets("Sheet2")

            '▼コピペ処理
            コピー対象.Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1)

            '▼よくわからないけど重複削除？
            '【省略】
        End With

    End Sub

Unionメソッドをすでに使っているところをみると、説明は不要ですよね？

ただ、このやり方の他に
オートフィルタを設定してから、B〜I列の（空白セル）【以外】を抽出して、まとめてコピーしたら、目的達成しそうな気がするので、そちらのほうがシンプルかもと思ったり・・・

（もこな２） 2019/02/15(金) 13:16

---

 一応、動いたけど、、結果がどうかは、、、わかりません。(^^;
Option Explicit
Sub コピー貼り付けつけ() 'コピー貼り付けつけのコード
'A列だけにデータがあれば、その全ての行はコピー貼り付けせず、その他の行のみコピー貼り付けする。(現在できていない状態)
Dim lastRow As Long
Dim 最終行番号 As Long
Dim i As Long
Dim N As Long
Dim 重複データを一括削除する As Variant
Dim myRng As Range
With Sheets("Sheet1")
    最終行番号 = .Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To 最終行番号
        N = Application.WorksheetFunction.CountA(.Range("A" & i & ":O" & i))
'        MsgBox N
        If N = 15 Then '(貼り付けない。15の時のみこの行を貼り付ける。）
            'Sheet1のA3から最終行までをコピー
            'Sheet2のA列の最終行の次の行に貼付け
            .Range("A" & i).Resize(, 15).Copy
            Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
End With
Application.CutCopyMode = False
'重複データを一括削除する
With Sheets("Sheet2")
    lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To lastRow
        If WorksheetFunction.CountIf(.Range(.Cells(i + 1, "O"), .Cells(lastRow, "O")), .Cells(i, "O")) > 0 Then
            If myRng Is Nothing Then
                Set myRng = .Cells(i, "O")
            Else
                Set myRng = Union(myRng, .Cells(i, "O"))
            End If
        End If
    Next i
End With
If Not myRng Is Nothing Then
    myRng.EntireRow.Delete
End If
End Sub
（SoulMan） 2019/02/15(金) 13:35

---

 こんにちは＾＾
おなじく一応、動いたけど、、結果がどうかは、、、わかりません。(^^;
重複削除ぶぶんはさわっていません。。。
m(_ _)m

 Sub コピー貼り付けつけ() 'コピー貼り付けつけのコード
    Dim lastRow As Long
    Dim myRng As Range
    Dim N As Long
    Dim i As Long
    Dim 最終行番号 As Long
    With Worksheets("Sheet1")
        最終行番号 = .Cells(.Rows.Count, 1).End(xlUp).Row
        Worksheets("Sheet2").Cells.Clear
        For i = 3 To 最終行番号
            N = Application.WorksheetFunction.CountA(Range("A" & i & ":O" & i))
            'MsgBox N
            If N = 15 Then '(貼り付けない。15の時のみこの行を貼り付ける。）
                'Sheet1のA3から最終行までをコピー
                .Range(.Cells(i, "A"), .Cells(i, "O")).Copy
                'Sheet2のA列の最終行の次の行に貼付け
                Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial
                Application.CutCopyMode = False
            End If
        Next i
    End With
    With Worksheets("Sheet2")

        '重複データを一括削除する
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 1 To lastRow - 1
            If WorksheetFunction.CountIf(.Range(.Cells(i + 1, "O"), .Cells(lastRow, "O")), .Cells(i, "O")) > 0 Then
                If myRng Is Nothing Then
                    Set myRng = .Cells(i, "O")
                Else
                    Set myRng = Union(myRng, .Cells(i, "O"))
                End If
            End If
        Next i
        If Not myRng Is Nothing Then
            myRng.EntireRow.Delete
        End If
    End With
End Sub
（隠居じーさん） 2019/02/15(金) 14:10

---

 こう↓してもいいように思うけど、、、結果がちょっと違うね？？？(^^;
Option Explicit
Sub コピー貼り付けつけ() 'コピー貼り付けつけのコード
'A列だけにデータがあれば、その全ての行はコピー貼り付けせず、その他の行のみコピー貼り付けする。(現在できていない状態)
Dim lastRow As Long
Dim 最終行番号 As Long
Dim i As Long
Dim N As Long
Dim 重複データを一括削除する As Variant
Dim myRng As Range
With Sheets("Sheet1")
    最終行番号 = .Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To 最終行番号
        If (Application.CountA(.Range("A" & i).Resize(, 15)) = 15) * (Application.CountIf(.Range("O2", .Range("O" & i)), .Range("O" & i)) = 1) Then
''        MsgBox N
'        If N = 15 Then '(貼り付けない。15の時のみこの行を貼り付ける。）
            'Sheet1のA3から最終行までをコピー
            'Sheet2のA列の最終行の次の行に貼付け
            .Range("A" & i).Resize(, 15).Copy
            Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
End With
Application.CutCopyMode = False
''重複データを一括削除する
'With Sheets("Sheet2")
'    lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'    For i = 1 To lastRow
'        If WorksheetFunction.CountIf(.Range(.Cells(i + 1, "O"), .Cells(lastRow, "O")), .Cells(i, "O")) > 0 Then
'            If myRng Is Nothing Then
'                Set myRng = .Cells(i, "O")
'            Else
'                Set myRng = Union(myRng, .Cells(i, "O"))
'            End If
'        End If
'    Next i
'End With
'If Not myRng Is Nothing Then
'    myRng.EntireRow.Delete
'End If
End Sub
（SoulMan） 2019/02/15(金) 14:38

---

 で、その条件でいいのなら、見出しも含めて↓とも書けるかもしれませんね
Option Explicit
Sub コピー貼り付けつけ() 'コピー貼り付けつけのコード
Dim MyA As Variant
Dim MyAry As Variant
Dim i As Long
Dim j As Long
Dim k As Long
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 15).Value
    MyAry = Application.Transpose(Application.Index(MyA, 1, 0))
    For i = 2 To UBound(MyA, 1)
        If (Application.CountA(Application.Index(MyA, i, 0)) = 15) * (Application.CountIf(.Range("O2", .Range("O" & i)), .Range("O" & i)) = 1) Then
            k = k + 1
            ReDim Preserve MyAry(LBound(MyAry, 1) To UBound(MyAry, 1), 1 To k)
            For j = LBound(MyAry, 1) To UBound(MyAry, 1)
                MyAry(j, k) = MyA(i, j)
            Next
        End If
    Next
End With
With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
End With
Erase MyA, MyAry
End Sub
（SoulMan） 2019/02/15(金) 15:18

---

 SoulManさんの条件文をパクらせていただいて。。。(￣▽￣；)
じーさん風アラカルト。。。みたいな。。。m(_ _)m
Option Explicit
Sub jisan()
    Dim s1 As Worksheet
    Dim r As Range
    Dim rr As Range
    Dim i As Long
    Dim WF
    Set WF = WorksheetFunction
    Set s1 = Worksheets("Sheet1")
    Set rr = s1.Range("A1").CurrentRegion
    s1.Copy
    With ActiveSheet
        Intersect(.UsedRange, .Range(.Rows(2), .Rows(.UsedRange.Rows.Count))).Delete
        For i = 2 To rr.Rows.Count
            If (WF.CountA(rr(i, 1).Resize(, 15)) = 15) * _
               (WF.CountIf(s1.Range(rr(2, 15), rr(i, 15)), rr(i, 15)) = 1) Then
               .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 15) = rr(i, 1).Resize(, 15).Value
            End If
        Next
        Application.CutCopyMode = False
    End With
End Sub
（隠居じーさん） 2019/02/15(金) 16:30

---

なるほど。隠居じーさんさん、SoulManさんが整理されたコードをみて合点がいきました。

重複削除のところは、要はO列だけみて（他の列は重複してなくても）行ごと削除したいってことですね。
Excel2013とのことですから、デフォルトで重複削除という機能がありますから、これを使った方が楽ちんだと思います。

    Sub さんぷる()

        Dim 出力先 As Range
        Dim コピー対象 As Range
        Dim i As Long        

        '出力先のセット
        With Worksheets("Sheet2")
            Set 出力先 = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With        

        '「Sheet1」の操作
        With Worksheets("Sheet1")

            '▼オートフィルタを強制解除して抽出状態をクリア
            .AutoFilterMode = False

            '▼オートフィルタを設定
            .Range("A1").AutoFilter

            '▼B〜O列のいずれも（空白）でない行を抽出
            For i = 2 To 15
                .AutoFilter.Range.AutoFilter Field:=i, Criteria1:="<>"
            Next i

            '抽出された行があれば（見出し行を除いて）コピペ
            If .Cells(.Rows.Count, "A").End(xlUp).Row > 1 Then
                Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1), .Range("A:O")).Copy 出力先
            End If
        End With

        '「Sheet2」の操作
        With Worksheets("Sheet2")

            'O列が重複している行を削除
            With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 15)
                .RemoveDuplicates Columns:=15, Header:=xlNo
            End With
        End With

    End Sub

（もこな２） 2019/02/15(金) 19:06

---

もこな２さん・隠居じーさんさん・SoulManさんの色々な方々ほんとうに、有難うございました、できました。私だったら動かしてから、失敗を見つけるのと違って、よく色々なことに気がつくことに流石だなと感嘆します。経験と体験が豊富にある方々だからこそできるのだと思いました。また、今後ともお教え下さいますよう、よろしくお願いします。重ねてお礼申し上げます。
（エイワン） 2019/02/15(金) 21:43

---

以前は、オートフィルタばかり使っていたのですが、
最近は、フィルタオプションが便利だと思うようになりました。

 Sub test()
    Dim rngS As Range
    Dim rngD As Range
    Dim rngC As Range

    Set rngS = Worksheets("Sheet1").Cells(1).CurrentRegion
    Set rngD = Worksheets("Sheet2").Cells(1).CurrentRegion.Rows(1)
    Set rngC = rngS.Resize(2, 2).Offset(, rngS.Columns.Count + 1)

    rngC(2, 1).Formula = "=counta(a2:o2)=15"
    rngC(2, 2).Formula = "=countif($o$2:o2,o2)=1"

    rngS.AdvancedFilter xlFilterCopy, rngC, rngD
    rngC.ClearContents

 End Sub

（マナ） 2019/02/16(土) 13:58

---

マナさんありがとうございます。試していないので、試してみたいと思います。ただ、コードについて、初心者ですので検証しないとよく分からないところがあります。すみません。
（エイワン） 2019/02/17(日) 15:07

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.