EXCEL VBA 条件にあったものをコピー

質問

こんにちは。
VBA初心者です（いつまでたっても）

シート1とシート2は同じ表
シート1（10月）に下記のような表があるとして（範囲は決まっていて表の20行目から80行目）
　　シート1
印　　日付　　商品　　備考
　　　 11/3　　漬物　　長期保存可
1　　　11/4　　菓子　　日持ちしない
　　　 11/5　　果物　　日持ちしない

シート2（11月）に、
印で1がついたものをものを除いてコピーしたいのです。
　　シート2
印　　日付　　商品　　備考
　　　 11/3　　漬物　　長期保存可
　　　 11/5　　果物　　日持ちしない

シートの保護の関係でVBAでこれをやりたいのです。
よろしくお願いします。

回答No.4

keithin · ベストアンサー

２０行目が印とか記入してあるタイトル行だとして。

sub macro1()
　worksheets("Sheet1").unprotect
　worksheets("Sheet2").unprotect

　worksheets("Sheet2").range("A20:D80").clearcontents
　worksheets("Sheet1").range("A20:D80").autofilter field:=1, criteria1:="="
　worksheets("Sheet1").range("A20:D80").copy worksheets("Sheet2").range("A20")
　worksheets("Sheet1").autofiltermode = false

　worksheets("Sheet1").protect
　worksheets("Sheet2").protect
end sub

ぐらいで十分かと。

お礼

こんにちは。
回答ありがとうございます。
自分の思ってた風にできました。
ありがとうございました。

回答No.5

K Kazz（@JazzCorp）

テーブルの開始位置を可変にする機能を追加

Option Explicit
Sub SelectRows()
Const xFrom = "Sheet1"
Const xTo = "Sheet2"
Const xKey_Col = "A"
Const xMark = 1
Const xHeads = 1
Const xHead_Row = 20
Dim xSheet As Worksheet
Dim xHit As Boolean
Dim kk As Long
Dim nn As Long
Dim mm As Long
Dim xLast As Long
Dim xLast_To As Long
Application.ScreenUpdating = False
Set xSheet = Sheets(xFrom)
xLast = xSheet.Cells(Rows.Count, xSheet.Cells(1, xKey_Col).Column + 1).End(xlUp).Row
Sheets(xTo).Activate
ActiveSheet.UsedRange.Clear
xLast_To = xHead_Row
If (xHeads <> 0) Then
Application.CutCopyMode = False
Worksheets(xFrom).Rows(xLast_To & ":" & xLast_To + xHeads - 1).Copy
Rows(xLast_To & ":" & xLast_To + xHeads - 1).PasteSpecial Paste:=xlPasteAll
xLast_To = xLast_To + xHeads
End If
xLast_To = xLast_To - 1
For nn = xHead_Row + xHeads To xLast
If (xSheet.Cells(nn, xKey_Col).Value <> xMark) Then
xHit = False
For mm = nn To xLast
If (xSheet.Cells(mm, xKey_Col).Value = xMark) Then Exit For
xHit = True
Next mm
If (xHit) Then
Application.CutCopyMode = False
xSheet.Rows(nn & ":" & mm - 1).Copy
kk = xLast_To + (mm - nn)
Rows(xLast_To + 1 & ":" & kk).PasteSpecial Paste:=xlPasteValues
', Operation:=xlNone, SkipBlanks:=False, Transpose:=False
xLast_To = xLast_To + (mm - nn)
nn = mm
'If (nn > xLast) Then Exit For
Else
End If
End If
Next nn
Epilogue:
Application.CutCopyMode = True
Application.ScreenUpdating = True
End Sub

お礼

こんにちは。
回答ありがとうございます。
開始位置を可変するコードを追記していただきありがとうございます。
こんなコードがスラスラ書けたらいいのですが・・・。
自分では分からないところもありますので、勉強します。
ありがとうございました。

回答No.3

K Kazz（@JazzCorp）

Constのとこを環境に合わせて変更

Ｏption Explicit
Sub SelectRows()
Const xFrom = "Sheet1"
Const xTo = "Sheet2"
Const xKey_Col = "A"
Const xMark = 1
Const xHeads = 1
Dim xSheet As Worksheet
Dim xHit As Boolean
Dim kk As Long
Dim nn As Long
Dim mm As Long
Dim xLast As Long
Dim xLast_To As Long
Application.ScreenUpdating = False
Set xSheet = Sheets(xFrom)
xLast = xSheet.Cells(Rows.Count, xSheet.Cells(1, xKey_Col).Column + 1).End(xlUp).Row
Sheets(xTo).Activate
ActiveSheet.UsedRange.Clear
xLast_To = 0
If (xHeads <> 0) Then
Application.CutCopyMode = False
Worksheets(xFrom).Rows("1:" & xHeads).Copy
Rows(1 & ":" & xHeads).PasteSpecial Paste:=xlPasteAll
xLast_To = xHeads
End If
For nn = 1 + xHeads To xLast
If (xSheet.Cells(nn, xKey_Col).Value <> xMark) Then
xHit = False
For mm = nn To xLast
If (xSheet.Cells(mm, xKey_Col).Value = xMark) Then Exit For
xHit = True
Next mm
If (xHit) Then
Application.CutCopyMode = False
xSheet.Rows(nn & ":" & mm - 1).Copy
kk = (xLast_To + 1) + (mm - nn) - 1
Rows(xLast_To + 1 & ":" & kk).PasteSpecial Paste:=xlPasteValues
', Operation:=xlNone, SkipBlanks:=False, Transpose:=False
xLast_To = xLast_To + mm - nn
nn = mm
'If (nn > xLast) Then Exit For
Else
End If
End If
Next nn
Epilogue:
Application.CutCopyMode = True
Application.ScreenUpdating = True
End Sub

回答No.2

mu2011

コピー元シートに保護が掛かっている場合、Copyメソッド等は使えないと思うので普通に代入するぐらいでしょうか。

一例です。
因みにＢ列が空白の場合には終了させています。

Sub sample()
Dim st1 As Worksheet, st2 As Worksheet, i As Long, j As Long
Set st1 = Sheets("10月"): Set st2 = Sheets("11月")
st2.Cells.ClearContents
For i = 20 To 80
If st1.Cells(i, "B") = "" Then Exit Sub
If st1.Cells(i, "A") <> 1 Then
j = j + 1
St2.Cells(j, "A").Resize(, 4) = st1.Cells(i, "A").Resize(, 4).Value
End If
Next
End Sub

お礼

こんにちは。
回答ありがとうございました。

回答No.1

NYAN99

考え方としては、行コピーすればいいのでは？
シート1の表20行目から80行目をFor文で回して１行ずつ読み込む。
そしてその中で印のセルが1なら読み飛ばして次の行へ。

'１行をコピーして貼り付け（この場合は２行めを３行目に）
Range("2:2").Copy
Range("3:3").PasteSpecial

Rangeの前にActiveSheet名を指定してあげれば。。

お礼

こんにちは。
回答ありがとうございました。