ここから本文です

VBA・・・条件に一致するデータをコピーして別ブックに貼り付ける

nof********さん

2013/6/1417:20:14

VBA・・・条件に一致するデータをコピーして別ブックに貼り付ける

各列2行目以降にデータが入っていたときP列2行目以降に「小計」と入っていたらA列B列のデータを別ブックのA列B列2行目にコピーしたいのですが・・・


[元データ.xls]
1 番号 品物 年号 数量 計
2 10 りんご 2013 35 小計
3 25 ミカン 2012 10 小計
4 15 ぶどう 2012 15 累計
5 25 メロン 2013 25 累計
6 48 イチゴ 2010 94 累計
7 37 キウイ 2011 46 小計
8 14 バナナ 2013 54 累計
・ ・ ・ ・ ・ ・
・ ・ ・ ・ ・ ・
・ ・ ・ ・ ・ ・
上記のデータを下記のように別ブックにコピーしたいのです。

[コピー先データ.xls]

1 番号 品物 年号 数量 計
2 10 りんご
3 25 ミカン
4 37 キウイ





簡潔にまとめると、P列2行目以降のデータが空になるまで処理を繰り返して値に「小計」が含まれる場合、A列のデータをコピーして別ブックのA列2行目に貼り付ける。同様にB列のデータもコピーしてB列2行目に貼り付ける
上記のマクロを作成するのにご教授の程宜しくお願い致します。

オートフィルターを使用すれば簡単なことは分かっていますが、指定した列を保護している為、オートフィルターのマクロを作成すると保護解除しなければなりません。出来れば他の方法でマクロを作成したいのですが知識も経験値も乏しいのでご助力下さい。
宜しくお願い致します。

閲覧数:
4,745
回答数:
2
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

dfg********さん

2013/6/1512:09:13

オートフィルタを使わない方法で作ってみました。

ただし、
・VBAは「コピー元」、「コピー先」のどちらにおいても可。
・でも「コピー元」、「コピー先」両方とも開いている状態であること。
が条件です。

ちなみに、1万行の処理に0.2秒弱かかりました。
1万行程度のデータなら、ストレスを感じることなく
動作すると思います。

↓↓↓↓↓↓VBAここから↓↓↓↓↓↓↓↓↓↓↓↓
Sub Copy2Book()
Dim val() As Variant

Const bk1Name As String = "Book1.xlsm" 'コピー元ブック名
Const sh1Name As String = "sheet1" 'コピー元シート名
Const colVal1 As String = "A" 'コピー元「番号」列番号
Const colVal2 As String = "B" 'コピー元「品物」列番号
Const colKey As String = "P" 'コピー元「計」列番号
Const ro1St As Integer = 2 'コピー元データ開始行番号

Const bk2Name As String = "Book2.xlsm" 'コピー先ブック名
Const sh2Name As String = "sheet1" 'コピー先シート名
Const colOut As String = "A" 'コピー先出力開始列番号
Const ro2St As Integer = 2 'コピー先出力開始行番号

Const strKy = "小計" 'キー文字列

Dim sh1 As Worksheet, sh2 As Worksheet
Dim roEnd As Long, i As Long


Set sh1 = Workbooks(bk1Name).Worksheets(sh1Name)
Set sh2 = Workbooks(bk2Name).Worksheets(sh2Name)

roEnd = sh1.Cells(Rows.Count, colKey).End(xlUp).Row

ReDim val(1, 0)
n = 0
For i = ro1St To roEnd

If sh1.Cells(i, colKey) = strKy Then
If UBound(val, 2) < n Then ReDim Preserve val(1, n)
val(0, n) = sh1.Cells(i, colVal1).Value
val(1, n) = sh1.Cells(i, colVal2).Value
n = n + 1
End If
Next i

sh2.Cells(ro2St, colOut).Resize(n, 2) = WorksheetFunction.Transpose(val)
sh2.Activate

End Sub

質問した人からのコメント

2013/6/16 14:24:46

オートフィル使用しない方法で悩んでいたので助かりました!!
本当にありがとうございました!!

ベストアンサー以外の回答

1〜1件/1件中

ja7********さん

編集あり2013/6/1509:36:52

何か 同じ質問のようですが・・・
> 保護解除しなければなりません。
どうせ別ブック出力ですから・・・
先にシートのデータ範囲をコピーしてから処理すればいいかと思いますが・・・
あと、AdvancedFilterなら 保護されても機能すると思います。

前のにも回答しましたが、こんな感じで如何でしょうか。
1行目を見出しとします。
E~O列は、どうなっているんでしょうか。

Sub 小計抽出()
Dim Sh As Worksheet
Dim PathN As String
PathN = ThisWorkbook.Path
If PathN = "" Then
    MsgBox "一度 保存後に実行してください。 ", vbExclamation
    Exit Sub
End If
Application.ScreenUpdating = False
With Worksheets("Sheet1") '             <--- 元データシート指定
    Set Sh = Worksheets.Add
    .Cells.Copy Sh.Range("A1")
    Sh.Range("Z1").Value = .Range("P1").Value
    Sh.Range("Z2").Value = "小計"
    Sh.Name = .Name & "(小計)"
End With
Sh.Range("A1", Sh.Cells.SpecialCells(xlCellTypeLastCell)). _
                            AdvancedFilter Action:=xlFilterCopy, _
                            CriteriaRange:=Sh.Range("Z1:Z2"), _
                            CopyToRange:=Sh.Range("AA1"), Unique:=False
Sh.Range("A:Z").Delete
Sh.Range("C2", Sh.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
Sh.Move
ActiveWorkbook.SaveAs PathN & "\" & _
                            Replace(ThisWorkbook.Name, ".xls", "(小計).xls")
ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox PathN & " に" & String(2, vbLf) & Replace(ThisWorkbook.Name, _
                    ".xls", "(小計).xls") & "を作成しました。", vbInformation
Set Sh = Nothing
End Sub

あわせて知りたい

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる