お世話になります。
2個の条件に一致するものを別シートに抽出したいのですが、お知恵を貸してください。
Excelシートで下記のような表があります。
これをL列(品名)かつS列(品質)の条件に一致するデータで新しいシートを作成したいのですが、
その際に新しいシート名は"AA1"のようにしたいのです。
条件がC列(品名)だけであれば下記で動いたのですが…。
(データ)
A列 入荷日
I列 品目コード
L列 品名
S列 品質
V列 在庫
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
1/1・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・20
2/2・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・10
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
2/3・・・・01・・・・・・・BB・・・・・・・・1・・・・・・・・・10
※以下、最大100品目の行数10000程です。
↓↓
(実行後希望)
シート名 AA1
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
1/1・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・20
2/2・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・10
シート名 AA2
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10
シート名 BB1
A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V
2/3・・・・01・・・・・・・BB・・・・・・・・1・・・・・・・・・10
Sub Sheet抽出()
Dim i As Long, Lstrow As Long, myName As String
Dim MySht As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Sheets("sheet1")
'準備
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
myName = .Cells(i, 9)
'シートの存在確認
For Each MySht In Worksheets
If MySht.Name = myName Then
myFlg = True '既にシート在り!!
Sheets(myName).Range("a1") _
.CurrentRegion.Offset(1).ClearContents
Exit For
End If
Next
'新規シートの追加
If myFlg = False Then
Worksheets.Add.Name = myName
End If
With Sheets(myName)
.Range("A1") = "入荷日"
.Range("I1") = "品名コード"
.Range("L1") = "品名"
.Range("S1") = "品質"
.Range("V1") = "在庫"
End With
myFlg = False
Next
'データの転記
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
myName = .Cells(i, 9).Value
.Range("A" & i & ":V" & i).Copy _
Sheets(myName).Cells(Rows.Count, 1).End(xlUp).Offset(1)
With Sheets(myName)
.Activate
Lstrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 21) = ""
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 21) = _
"=SUM(v2:V" & Lstrow & ")"
End With
Next
End With
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End Sub
実行後希望のように抽出するには、どうすれば良いのでしょうか?
よろしくお願いいたします。
No.4ベストアンサー
- 回答日時:
ぎゃっはっはぁ~~!
なかなか解決しませんね。
>イメージとしてシート2以降の表示は、
>元データA列→新シートA列(1行目のタイトルも表示)
>元データI列→新シートB列(〃)
>元データL列→新シートC列(〃)
>元データS列→新シートD列(〃)
>元データV列→新シートE列(〃)
結局元データSheetのA・I・L・S・V列のデータだけを
新規SheetのA~E列に項目行も含めて表示させればよい訳ですよね?
コピー元の範囲と貼り付け先のセル番地だけの問題だと思います。
Sub Sample4()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
'↓★ココから変更
.Cells(1, "B").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
.Cells(1, "J").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("B1")
.Cells(1, "M").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("C1")
.Cells(1, "T").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("D1")
.Cells(1, "W").Resize(lastRow).SpecialCells(xlCellTypeVisible).Copy wS.Range("E1")
'↑★ココまで
wS.Name = wS2.Cells(k, "A")
wS.Columns.AutoFit
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub
これで何とかご希望通りになるでしょうか?m(_ _)m
ありがとうございました!!
おかげで希望通りのものができました。
貴重なお時間を何度も割いて頂き本当にありがとうございました!
m(_ _)m
No.3
- 回答日時:
続けてお邪魔します。
前回は余計なお世話を焼いてしまったようですね!
>A~I~L~S~Vの”~”の列は、シート2以降ではタイトルも非表示もしくは最初から表示しないようにはできますでしょうか?
No.2のコードにちょっとだけ手を加えて
1行目はなにもせずに、元データの2行目以降を各Sheetの各列2行目以降に貼り付けてみました。
Sub Sample3()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
.Cells(2, "B").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("A2")
.Cells(2, "J").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("I2")
.Cells(2, "M").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("L2")
.Cells(2, "T").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("S2")
.Cells(2, "W").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("V2")
wS.Name = wS2.Cells(k, "A")
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub
※ 各Sheetの1行目は空白セルになると思います。
もし1行目から項目なしの実データを表示したい場合は
各列の貼り付け先セル番地を1行目にしてください。
仮に今回のコードのA列だけでいえば
>.Cells(2, "B").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("A2")
を
> .Cells(2, "B").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
のように元データの2行目以降を追加したSheetの1行目に変更します。
もちろんA・I・L・S・V列すべてを変更です。
今度はどうでしょうか?m(_ _)m
この回答への補足
ご回答ありがとうございますm(__)m
コードを拝見して少しずつ勉強させて頂いております。
tom04先生、すみませんあと1回だけ…。
私の質問表現の仕方が悪くて申し訳ございません。
再度お手間なのですがご教示お願い致します。
イメージとしてシート2以降の表示は、
元データA列→新シートA列(1行目のタイトルも表示)
元データI列→新シートB列(〃)
元データL列→新シートC列(〃)
元データS列→新シートD列(〃)
元データV列→新シートE列(〃)
元データB列→新シートでは表示しない
元データC列→新シートでは表示しない
…
というような感じなのですが、説明が拙くてすみません。
もう少々お知恵をお貸しくださいm(_ _;)m
No.2
- 回答日時:
No.1です。
>シート2以降の抽出表示はAISLV列だけにしたい場合
というコトですので、粛々と列を選択するよう変更してみました。
尚、元データと同じ列のA・I・S・L・V列に貼り付けています。
(1行目の項目行は他の列もすべて貼り付けとします)
Sub Sample2()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
.Rows(1).Copy wS.Range("A1")
wS.Range("A1").Delete shift:=xlToLeft
Range(.Cells(1, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
Range(.Cells(1, "J"), .Cells(lastRow, "J")).SpecialCells(xlCellTypeVisible).Copy wS.Range("I1")
Range(.Cells(1, "M"), .Cells(lastRow, "M")).SpecialCells(xlCellTypeVisible).Copy wS.Range("L1")
Range(.Cells(1, "T"), .Cells(lastRow, "T")).SpecialCells(xlCellTypeVisible).Copy wS.Range("S1")
Range(.Cells(1, "W"), .Cells(lastRow, "W")).SpecialCells(xlCellTypeVisible).Copy wS.Range("V1")
wS.Name = wS2.Cells(k, "A")
wS.Columns.AutoFit
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub
※ 元データSheetに作業列A列を挿入 → コピー&ペースト → 最後にA列を削除 としていますので、
コピー元がすべて1列ずつ右側にずれています。
今度はどうでしょうか?m(_ _)m
この回答への補足
再度の早々のご回答大変ありがとうございます!
こちらも勿論上手く動いてくれているのですが、実は元データのタイトル行がIV列まであるのです‥。
A~I~L~S~Vの”~”の列は、シート2以降ではタイトルも非表示もしくは最初から表示しないようにはできますでしょうか?
すでに初心者の私にはHiddenを組み込めばいいのだろうか…としか思考が追いつかず、度々のお願いで恐縮ですがもう少しの間お知恵をお貸しくださいm(_ _;)m
No.1
- 回答日時:
こんばんは!
一例です。
元データはSheet見出しの一番左側にあるとします。
>※以下、最大100品目の行数10000程です
というコトですので10000行をループさせてもいいのですが、時間ばかりかかり
Excelが「応答なし」になる可能性がありますので、フィルタで処理してみました。
標準モジュールです。
Sub Sample1()
Dim k As Long, lastRow As Long, wS As Worksheet, wS2 As Worksheet
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(2, "A"), .Cells(lastRow, "A"))
.Formula = "=M2&T2"
.Value = .Value
End With
Worksheets.Add after:=Worksheets(1)
Set wS2 = Worksheets(Worksheets.Count)
Range(.Cells(1, "A"), .Cells(lastRow, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Range("A1")
.ShowAllData
For k = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AutoFilter field:=1, Criteria1:=wS2.Cells(k, "A")
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS = Worksheets(Worksheets.Count)
Range(.Cells(1, "B"), .Cells(lastRow, "W")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
wS.Name = wS2.Cells(k, "A")
Next k
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Delete
End With
Application.DisplayAlerts = True
End Sub
※ Sheet見出しの一番左側Sheet以外は一旦削除 → Sheet追加 としていますので
Sheet2やSheet3が存在し、データがある場合はなくなってしまいますので、
別Bookでマクロを試してみてください。m(_ _)m
この回答への補足
早いご回答ありがとうございます!
頂いたコード希望通り動きました。
補足で申し訳ないのですが、シート2以降の抽出表示はAISLV列だけにしたい場合、
こちらのコードはどう変更させれば良いでしょうか?
お手数をお掛けしますがよろしくお願いいたします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) まとめシートから集計シートへA列のコードが一致したら1行コピーするマクロをネット上で見つけました。こ 1 2022/08/30 14:11
- Visual Basic(VBA) 前回ご教授いただいたコードに覚えたてのループ処理で品名りんごAから順に20回for nextでループ 7 2023/01/13 22:01
- Excel(エクセル) マクロで最終行から上に検索を逆にしたい 1 2022/05/17 18:27
- Visual Basic(VBA) ExcelVBAでDo Until loopのネスト、IF文を使って一致する物と一致しない物としたい 11 2022/12/24 17:46
- Visual Basic(VBA) コード名シートA列と集計シートA列のコードが一致したら、コード名シートA5からk12の範囲をコピーし 1 2022/08/29 23:46
- Visual Basic(VBA) Sheet3から2つの条件でオートフィルターで抽出した個数をSheet2へ入力するマクロで、一つ目の 4 2023/01/12 23:40
- Visual Basic(VBA) VBA 請求書自動作成 3 2022/04/24 01:58
- Visual Basic(VBA) excel vbaでvlooupの変数がわかりません。 7 2022/05/30 09:35
- Visual Basic(VBA) 形式を選択して貼り付け 以下のコードで「元」シートと「先」シートのA列に同じ値があったら指定範囲をコ 5 2022/11/11 07:30
- Visual Basic(VBA) 別シートのデータを参照して値を入れたい。 まとめデータシートのC列D列の値を商品一覧シートのコードが 7 2022/08/17 13:20
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
B列の最終行までA列をオート...
-
Worksheets メソッドは失敗しま...
-
vba 2つの条件が一致したら...
-
IIF関数の使い方
-
Excelで、あるセルの値に応じて...
-
Cellsのかっこの中はどっちが行...
-
VBAのFind関数で結合セルを検索...
-
VBAの構文 3列置きにコピーし...
-
データグリッドビューの一番最...
-
VBAで指定範囲内の空白セルを左...
-
VBAを使って検索したセルをコピ...
-
マクロ 最終列をコピーして最終...
-
【VBA】2つのシートの値を比較...
-
VBA 何かしら文字が入っていたら
-
URLのリンク切れをマクロを使っ...
-
VBA 列が空白なら別のマクロへ...
-
特定のキーワードを含む行を別...
-
重複データの合算(VBA)
-
VBマクロ 色の付いたセルを...
-
VBAでのリスト不一致抽出について
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
B列の最終行までA列をオート...
-
Worksheets メソッドは失敗しま...
-
Excelで、あるセルの値に応じて...
-
vba 2つの条件が一致したら...
-
IIF関数の使い方
-
VBAを使って検索したセルをコピ...
-
Cellsのかっこの中はどっちが行...
-
文字列の結合を空白行まで実行
-
マクロ 最終列をコピーして最終...
-
URLのリンク切れをマクロを使っ...
-
Changeイベントでの複数セルの...
-
VBAのFind関数で結合セルを検索...
-
ExcelVBA修正のお願い
-
データグリッドビューの一番最...
-
VBAで指定範囲内の空白セルを左...
-
VBA 何かしら文字が入っていたら
-
【VBA】2つのシートの値を比較...
-
VBマクロ 色の付いたセルを...
-
空白セルをとばして転記
-
rowsとcolsの意味
おすすめ情報