[[20180311152653]] 『一つのシートの特定行を複数のシートにわけて移動』(ひろひろ) ページの最後に飛ぶ

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

 

『一つのシートの特定行を複数のシートにわけて移動する』(ひろひろ)

A列に品名 B列に店名 C列に数量があるデータがあります。

A列   B列   C列
りんご あああ  2
みかん いいい  3
りんご ううう  2
バナナ えええ  7
すいか あああ  5
いちご えええ  1
みかん いいい  2

B列の店名(あああ)行を全て既に作成済の別のシート(あああシート)へ切り取って貼り付け
B列の店名(いいい)行を全て既に作成済の別のシート(いいいシート)へ切り取って貼り付け
B列の店名(ううう)行を全て既に作成済の別のシート(うううシート)へ切り取って貼り付け

し、最初にシートから全てデータを移動させたいです。

下記のようなVBAを作成しましたが、200件ほどのデータに15分もかかりました。

Sub Macro2()

' Macro2 Macro
'

'

    Dim i, LastRow As Long
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 1 To LastRow
    If Cells(i, 2) = "あああ" Then
    Rows(i).Cut Sheets("あああ").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    ElseIf Cells(i, 2) = "いいい" Then
    Rows(i).Cut Sheets("いいい").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    ElseIf Cells(i, 2) = "ううう" Then
    Rows(i).Cut Sheets("ううう").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    ElseIf Cells(i, 2) = "えええ" Then
    Rows(i).Cut Sheets("えええ").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    ElseIf Cells(i, 2) = "おおお" Then
    Rows(i).Cut Sheets("おおお").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   End If
Next i
End Sub

もっと簡単にわけるほうほうはないでしょうか?

マクロ初心者です。

< 使用 Excel:Excel2013、使用 OS:Windows8 >


こんな感じでどうですか

1)1行目に見出し行挿入
2)「あああ」でオートフィルタ
3)抽出された行を転記
4)「いいい」「ううう」…で同様に転記
5)データをクリア

(マナ) 2018/03/11(日) 15:58


上記の方法で行っておりますが、マクロで実行するよりが上記のほうはやいでしょうか?
10店舗以上あり毎月同じ作業なのでマクロでできればと思ったのですが・・・
(ひろひろ) 2018/03/11(日) 16:00

>上記の方法で行っておりますが、

その作業をマクロにするのです。

ますは、「あああ」について考えてください。
「マクロの記録」を叩き台にしてもよいし、
ネットでオートフィルタのマクロを探してもよいです。

(マナ) 2018/03/11(日) 16:07


Sub Macro4()
'
' Macro4 Macro
'

'

    ActiveSheet.Range("$A$2:$V$1194").AutoFilter Field:=2, Criteria1:="1"
    Rows("3:3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Sheets("あああ").Select
    Rows("3:3").Select←ここ
    ActiveSheet.Paste
    Sheets("全店").Select
    ActiveSheet.Range("$A$2:$V$1194").AutoFilter Field:=2, Criteria1:="2"
    Rows("218:218").Select ←ここ
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Sheets("いいい").Select
    Rows("3:3").Select
    ActiveSheet.Paste
    Sheets("全店").Select
    ActiveSheet.Range("$A$2:$V$1194").AutoFilter Field:=2, Criteria1:="3"
    Rows("308:308").Select←ここ
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Sheets("ううう").Select
    Rows("3:3").Select
    ActiveSheet.Paste
    Sheets("全店").Select
End Sub

マクロの記録を使ってみましたが、毎回データ量が変化するので ←ここの箇所
Rows("218:218").Select
Rows("308:308").Select
はどのようにかけばいいのかわかりません(><)

(ひろひろ) 2018/03/11(日) 16:20


全データ範囲を丸ごとコピーするとよいです。
非表示の行は、コピーされません。
 Sub test()

    With Sheets("全店").Range("A2:V1194")
        .AutoFilter Field:=2, Criteria1:="1"
        .Offset(1).Copy Sheets("1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With

 End Sub

(マナ) 2018/03/11(日) 16:31


できました!ありがとうございます。

ちなみにコピペでなくて、カット&貼付はできないのでしょうか?

それと、最初のRange("A2:V1194")のV1194は今回の最終データ行ですが、ここも変動するのですがその場合はどうすればいいですか?

マクロの記録を使っただけなので全くわからず何度も申し訳ございません。

(ひろひろ) 2018/03/11(日) 16:52


>ちなみにコピペでなくて、カット&貼付はできないのでしょうか?

手作業でできるかどうか確認してみてください。
手作業でできれば、マクロでも可能です。

ところで、全データを転記するのなら、
最後に、全データをまとめて消去するのではだめなのですか?

>最初のRange("A2:V1194")のV1194は今回の最終データ行ですが、ここも変動するのですが

わたしなら、Range("A2:V10000")とでもしておきます。

(マナ) 2018/03/11(日) 17:01


全データをまとめて消去するのではだめなのですか?

結果は同じなので問題ないです。
手作業でカット&ペーストをしていたので考え方が固持していただけですね。すいません。

わかりやすく説明していただきありがとうございました。

(ひろひろ) 2018/03/11(日) 17:08


ども^^

シート毎に特定のデータだけを振り分けるという要望は多いですが、
そもそも、
シートタブを選択したときに、
シートタブの名前のデータだけが見えればいいのだから、
事前に振り分けておく必要はないと思います。
マクロを使うなら、シートを分ける必要もないのですが、
「シートを選択する」という操作が、ユーザー的にわかりやすいみたいですね。
また、データが次々更新される場合にも、
その都度必要なものだけを抽出するほうが柔軟に対応できるかなとおもいます。
そうすることで、不要なループを避け、
一見高速化されたようにできると思います。

ThisWorkbookモジュールに

Option Explicit

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    Dim rngList As Range

    Sh.UsedRange.Clear
    Set rngList = Sheets("全店").Range("A2").CurrentRegion.Offset(1)

    With rngList
        .AutoFilter Field:=2, critea1:=Sh.Name
        If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            .Copy Sh.Range("A1")
        End If
        .AutoFilter
    End With
End Sub

ただし、たくさんのシートが1つのブックに存在してることが僕的にはストレスなので、
ピボットテーブルで対応したい気がします。
そうすることでわけのわからないマクロと格闘することも避けられます。

(まっつわん) 2018/03/11(日) 17:15


 こんばんは!
私もちょっと考えてみました。
Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyAry() As Variant
Dim MyDic As Object
Dim wh As Worksheet
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim MyFlg As Boolean
Application.ScreenUpdating = False
    With Sheets("Sheet1")
        MyA = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3).Value
        Set MyDic = CreateObject("Scripting.Dictionary")
        For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
            If Not IsEmpty(MyA(i, 2)) Then
                MyDic(MyA(i, 2)) = Empty
            End If
        Next
        x = MyDic.Keys
        y = MyDic.Keys
        For i = LBound(x) To UBound(x)
            x(i) = .Range("A1:C1").Value
        Next
        For i = LBound(x) To UBound(x)
            MyFlg = False
            For Each wh In Worksheets
                If wh.Name = y(i) Then MyFlg = True
            Next
            If MyFlg = False Then
                Sheets.Add , Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = y(i)
            End If
        Next
    End With
    For i = LBound(MyA, 1) To UBound(MyA, 1)
        z = Application.Match(MyA(i, 2), y, 0)
        If Not IsError(z) Then
            MyAry = Application.Transpose(x(z - 1))
            k = UBound(x(z - 1), 1)
            k = k + 1
            ReDim Preserve MyAry(LBound(MyAry, 1) To UBound(MyAry, 1), 1 To k)
            For j = LBound(MyA, 2) To UBound(MyA, 2)
                MyAry(j, k) = MyA(i, j)
            Next
            x(z - 1) = Application.Transpose(MyAry)
        End If
    Next
    For i = LBound(x) To UBound(x)
        With Sheets(y(i))
            .Cells.Clear
            .Range("A1").Resize(UBound(x(i), 1), UBound(x(i), 2)).Value = x(i)
            .UsedRange.EntireColumn.AutoFit
        End With
    Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Erase MyA, MyAry, y, x
MsgBox "処理が完了しました"
End Sub
※先日の使いまわしなもんですみません。
v(=∩_∩=)v
(SoulMan) 2018/03/11(日) 17:32

コメント返信:

[ 一覧(最新更新順) ]


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