システムメンテナンスのお知らせ

お世話になります。以下の例のように
元のデータを 品名ごとの別シートに 日付順に並べて 貼り付けられるように
したいのですが、どのようにコードを組めばよいかご教授 頂けないでしょうか。



元データsheet
A列     B列    C列     D列
日付     品名        個数
2/1      りんご       50
2/13     みかん       150
3/22    りんご       75
2/10    りんご       100
3/13    みかん       120


抽出先りんごsheet
A列     B列    C列    D列
日付     品名    個数
2/1     りんご   50
2/10     りんご   100
3/22     りんご   75

よろしくお願い致します。

gooドクター

A 回答 (8件)

VBA勉強中と云うことなので、「こんな方法もあるよ」的な回答をさせていただきます。


抽出元を抽出先にコピーして、そこから「りんご」以外を削除するロジックとなっています。
なお、抽出先のシートが存在していないとエラーになります。また、抽出対象の「りんご」が無い場合も、エラーになりますので、必要であれば、notimeさんの方で組み込んでください(勉強の一環として)。

Sub りんご()
Dim ToWs As Worksheet
Dim DifRng As Range
Set ToWs = Worksheets("抽出先りんごsheet")
Worksheets("元データsheet").Columns("A:D").Copy Destination:=ToWs.Columns("A:D")
ToWs.Columns("C").Delete
With ToWs.Range("B2:B" & Rows.Count)
Set DifRng = .Find(What:="りんご", LookIn:=xlFormulas, LookAt:=xlPart)
.ColumnDifferences(DifRng).EntireRow.Delete
End With
ToWs.Range("A:C").Sort key1:=ToWs.Range("A1"), order1:=xlAscending, Header:=xlYes
End Sub
    • good
    • 6
この回答へのお礼

ママチャリ様
ご回答ありがとうございました。
非常に参考になりました。
うまくいきました、ありがとうございました。

お礼日時:2017/03/13 09:20

No.5・6です。



>「りんご」というマクロ実行ボタンを作成して・・・

「元データ」シートにコマンドボタンを挿入しているとします。

Private Sub CommandButton1_Click()
Dim k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
With Worksheets("元データ")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
sN = "りんご"
.Rows(1).AutoFilter , field:=2, Criteria1:="りんご"
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
.Range(Cells(1, "A"), Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Range("C:C").Delete
wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes
.AutoFilterMode = False
Else
MsgBox "該当データなし"
End If
End With
End Sub

こういう感じで良いのでしょうか?m(_ _)m
    • good
    • 0
この回答へのお礼

tomo04様
ご回答ありがとうございました。
また御礼が遅くなり大変申し訳ありませんでした。
頂きましたコードですと、みかん等も一緒に移動して
しまうのですが、これを元に立て直してみたいと思います。
ありがとうございました。

お礼日時:2017/03/13 09:17

No.5です。



投稿後気づきました。
日付順に並び替えが必要でしたね。前回のコードは消去し↓のコードにしてください。
(「★」の行を追加しています)

Sub Sample2()
Dim i As Long, k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Worksheets("元データ")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("E:E").Insert
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("E1"), unique:=True
For i = 2 To .Cells(Rows.Count, "E").End(xlUp).Row
sN = .Cells(i, "E")
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
myFlg = False
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
.Rows(1).AutoFilter field:=2, Criteria1:=sN
Range(.Cells(1, "A"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Range("C:C").Delete
wS.Range("A1").CurrentRegion.Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes '★
wS.Move after:=Worksheets(i - 1)
Next i
.Range("E:E").Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

どうも失礼しました。m(_ _)m
    • good
    • 0
この回答へのお礼

ご回答ありがとうございます。
VBA を勉強している最中で、まだコードの内容を完全に
把握できない状態なのですが、もしよろしければ
例)にあるように組むことはできますでしょうか?
「りんご」というマクロ実行ボタンを作成して、
りんごを、抽出先りんごsheet に移すことができれば、、
と目指しております。。

お礼日時:2017/03/10 19:02

こんにちは!



一例です。
シート名「元データ」はシート見出しの一番左側にあるとします。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Worksheets("元データ")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("E:E").Insert
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("E1"), unique:=True
For i = 2 To .Cells(Rows.Count, "E").End(xlUp).Row
sN = .Cells(i, "E")
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
myFlg = False
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
.Rows(1).AutoFilter field:=2, Criteria1:=sN
Range(.Cells(1, "A"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Range("C:C").Delete
wS.Move after:=Worksheets(i - 1)
Next i
.Range("E:E").Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか?m(_ _)m
    • good
    • 1

データの貼り付け先は、以下のようになりますが、


元データのA列

抽出先のA列

元データのB列

抽出先のB列

元データのD列

抽出先のC列

抽出先のD列はなにも設定しなくて良いですか?
    • good
    • 0
この回答へのお礼

はい、抽出先のD列はなにも設定しない形を希望しています。

お礼日時:2017/03/10 18:43

    • good
    • 1
この回答へのお礼

ありがとうございます、このような回答方式があるとは知りませんでした。
参考にさせて頂きます。

お礼日時:2017/03/10 19:03

こんにちは


サンプルソースです(と、言いつつ、"マクロの記録"ですが)。
手順として
1.A1を選択
2.フィルタでB列が”りんご”を抽出
3.Ctrl+Aで選択
4.新しいシートを作成
5.そのまま、ペースト
です。

3番目が、
Range("A1:C6").Select
で記録されていますので、
Cells.Select
に書きなおした方が、汎用性が高まります。

その他の点は、
・実際の使用状況
・使う人のレベル
で異なりますので、補足等してください。

Sub Macro1()
'
' Macro1 Macro
'

'
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$6").AutoFilter Field:=2, Criteria1:="りんご"
Range("A1:C6").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
End Sub
    • good
    • 1

貼付先は一度クリアしてから貼付で良いのでしょうか?

    • good
    • 0
この回答へのお礼

早速のご回答ありがとうございます。
貼付先は一度クリアしてから、を希望しております。

お礼日時:2017/03/10 15:40

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

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

gooドクター

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

人気Q&Aランキング