[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一つのシートの特定行を複数のシートにわけて移動する』(ひろひろ)
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
その作業をマクロにするのです。
ますは、「あああ」について考えてください。
「マクロの記録」を叩き台にしてもよいし、
ネットでオートフィルタのマクロを探してもよいです。
(マナ) 2018/03/11(日) 16:07
'
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.