[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA 条件ごとに雛形に貼り付けシート作成』（ぶぶ）
元データのシートから条件ごとに雛形に貼り付けてシートを作成したいです。
下記のコードを作成し、条件ごとにシートを作成するのは出来ました。
条件ごとにできたシートのＢ2からＥ列の最終行までを雛形シートのＪ11：Ｍ65に貼り付けてシートを完成させたいです。また条件ごとにできたシートのデータが35行以上あると雛形からはみ出してしまうので新しいシートを作成したいのですがどうしたらいいのでしょうか？
ご教授頂きたいです。
Sub test()
Dim ws As Worksheet Dim I As Long
'dataｼｰﾄの項目・長さ・巾の順に並び替え
With Sheets("data").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("I:I"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("L:L"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("K:K"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("I:M")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'不要な列を削除
Range("A:H,N:N").Select
Selection.Delete Shift:=xlToLeft
'元シートをコピーし作業用シートを作成。グループでソート＆重複を削除する。
Sheets("data").Copy After:=Sheets(1)
Set ws = ActiveSheet
ws.Range("A:E").RemoveDuplicates Columns:=1, Header:=xlYes
'グループ毎のシート生成。
For I = 2 To ws.UsedRange.Rows.Count
If ws.Cells(I, 1) = "" Then Exit For
Sheets("data").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Range("A:E").AutoFilter Field:=1, Criteria1:="<>" & ws.Cells(I, 1), _
Operator:=xlAnd
.Rows("2:" & .UsedRange.Rows.Count).Delete Shift:=xlUp
.Range("A:E").AutoFilter
.Name = ws.Cells(I, 1)
End With Next I
'作業用シートの削除。 Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
おはようございます ＾＾ コードは動作していますがデーターの配置情報、種類等がコードからしか想像出来ません 下記はdataシートのＡ１〜Ｔ５０にそれぞれのセルアドレスを入力したダミーデーター で作動させ出来たシートの一部です、５０シート、全て下記の様なフォーマットになります。 二行目の情報がシートにより変化します＾＾； 合っているのか、間違いなのか判断できません。 一行目はきっと項目名なのでしょうね。＾＾ (これだとソートがうまくいかないので解りづらい結果になっているのですが ^^;;; ) 。。。三行目以降はありません。
もう少し詳しく読込み情報、書込み情報、雛形シートの概要等を解りやすく説明されると
回答がつきやすいとおもいますです。
' A B C D E F G H I J K 1 I1 B5 K1 B6 M1 O1 B8 Q1 B9 S1 B10 2 I10 B14 K10 B15 M10 O2 B9 Q2 B10 S2 B11 （隠居じーさん） 2018/06/09(土) 08:12
または別の目的があるのですか？
（まっつわん） 2018/06/09(土) 09:32
そして雛形はただ印刷するためのものです。印刷し取引先へ送付しています。なので枠からはみ出さないようにしたいです。
（ぶぶ） 2018/06/10(日) 18:45
↓この文章からは、55行分貼り付けできそうですが？
＞雛形シートのＪ11：Ｍ65に貼り付けてシートを完成させたいです。
（マナ） 2018/06/10(日) 19:05
（ぶぶ） 2018/06/11(月) 08:53
まず55行を転記し、印刷
次の55行を転記し、印刷
これを繰り返します。
データがなくなれば、
次の等級で同様に繰り返します。
Option Explicit
Sub test()
Dim 貼付先 As Range
Dim ws As Worksheet
Set 貼付先 = Worksheets("雛形").Range("J11;M65")
'1)作業用シート作成
Set ws = Worksheets.Add
'2)作業用シートに､等級ごとに抽出（フィルタオプション）
'3)並べ替え
'4)最終行取得
'5)55行単位で転記し印刷を繰り返し
For i = 2 To 最終行 Step 55
貼付先.Value = ws.Range("B" & i).Resize(55, 4).Value
Worksheets("雛形").PrintOut
Next
'6)2〜5)をすべての等級で繰り返し
'7)作業用シート削除
'8)貼付先.ClearContents
End Sub
（マナ） 2018/06/11(月) 19:09
ぞれぞれのシートを作成しシート名を
等級名（1）、（2）...としたいのですがどのようなコードにしたらよいのでしょうか？
.Name=ws.Cells(i,1)&"ここを（1）や（2）にしたい"
（ぶぶ） 2018/06/12(火) 14:17
Option Explicit
Sub test2()
Dim ws As Worksheet
'1)作業用シート作成
Set ws = Worksheets.Add
'2)作業用シートに､等級ごとに抽出（フィルタオプション）
'3)並べ替え
'4)最終行取得
'5)55行単位で転記し印刷を繰り返し
cnt = 0
For i = 2 To 最終行 Step 55
cnt = cnt + 1
Worksheets("雛形").Copy after:=Worksheets(Worksheets.Count)
With ksheets(Worksheets.Count)
.Name = 等級 & " (" & cnt & ")"
.Range("J11;M65").Value = ws.Range("B" & i).Resize(55, 4).Value
.PrintOut
End With
Next
'6)2〜5)をすべての等級で繰り返し
'7)作業用シート削除
End Sub
（マナ） 2018/06/12(火) 18:47
>'2)作業用シートに､等級ごとに抽出（フィルタオプション） ここの部分ですがフィルタオプションの配列がどうしてもうまくいきません。
何の等級があるかはデータによって違うのですが
それでも作業用ｼｰﾄは一つで良いのでしょうか？
（ぶぶ） 2018/06/13(水) 16:19
問題ありません。
まずは、一つの等級についてフィルタオプションで抽出・転記するコードを考えてみてください。
すべての等級で繰り返すコードに修正するのは、その後でもできます。
（マナ） 2018/06/13(水) 18:19
テストで記録でですがデータのシートから抽出したら下記のコードになりました。（条件関係なく抽出しています）
Sheets("data").Columns("I:M").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("data").Columns("I:I"), CopyToRange:=Columns("A:E"), _
Unique:=False
CriteriaRange:=Sheets("data").Columns("I:I") ここの.Columnsを条件にかえていくコードになるのでしょうか？
また等級で"FRYO"という項目がたまに出てくるのですがそれは"CUT"と一緒に抽出したいのですが・・・
どうしたらいいのでしょうか？
（ぶぶ） 2018/06/14(木) 15:21
ならば、少し変更して、
作業用シートは、新規シートを使うのでなく、
dataシートを複製し、それを作業用シートとします。
で、"FRYO"を"CUT"に置換してしまってはどうでしょうか。
'----
＞フィルタオプションは使ったことがない
フィルタオプション部分を理解するために
以下のマクロを、ステップ実行で確認してみてください。
Option Explicit
Sub test()
Dim ws As Worksheet
Sheets("data").Copy after:=Worksheets(1)
Set ws = ActiveSheet
ws.Range("J1:M1").Copy ws.Range("AA1")
ws.Columns("I").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ws.Range("Y1"), Unique:=True
ws.Columns("J:M").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("Y1:Y2"), CopyToRange:=ws.Range("AA1:AD1"), Unique:=False
ws.Range("Y2").Delete Shift:=xlShiftUp
ws.Columns("J:M").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("Y1:Y2"), CopyToRange:=ws.Range("AA1:AD1"), Unique:=False
ws.Range("Y2").Delete Shift:=xlShiftUp
End Sub
'----
＞フィルタオプションは抽出する条件のセルを用意しなければ抽出できないのでしょうか？
はい。そうです。
作業用セルを使います。マクロで最後に消してしまえば問題ありません。
今回は、作業用シートごと削除してしまえばよいです。
（マナ） 2018/06/14(木) 19:45
なるほど！！置き換えて、転記してからまた戻すという作業も可能ですか？
そのようにしたい理由は雛形の方でＧ列にも入力する文字があるのですが、それは"CUT"と"FRYO"では入れる文字が違うのです・・
フィルタオプションのコードありがとうございます。
＞ws.Columns("J:M").AdvancedFilter Action:=xlFilterCopy, _
＞CriteriaRange:=ws.Range("Y1:Y2"), CopyToRange:=ws.Range("AA1:AD1"), Unique:=False
ここではなにも動きがないのはなぜでしょうか？
（ぶぶ） 2018/06/15(金) 10:32
（マナ） 2018/06/15(金) 12:42
どこを修正したらいいですか？
Sub test()
Dim ws As Worksheet
Dim n As Long
Sheets("data").Copy after:=Worksheets(1)
Set ws = ActiveSheet
ws.Range("J1:M1").Copy ws.Range("AA1")
ws.Columns("I").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ws.Range("Y1"), Unique:=True
For n = 2 To ws.UsedRange.Rows.Count
If ws.Cells(n, 25) = "" Then Exit For
ws.Columns("I:M").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("Y1:Y2"), CopyToRange:=ws.Range("AA1:AD1"), Unique:=False
ws.Range("Y2").Delete Shift:=xlShiftUp
Next
End Sub
（ぶぶ） 2018/06/15(金) 15:44
なので。
Y2が空白になったら、終了
としてください。
（マナ） 2018/06/15(金) 18:52
もっと勉強し使いこなせるようにしたいと思います。
マナ様、重ね重ねご教授頂きありがとうございました。
（ぶぶ） 2018/06/18(月) 09:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.