[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『オートフィルタで抽出したデータを、別シートの特定セルに貼りつけたい』（まっくん）
いつもお世話位なっております、まっくんです。
表題の通りの質問なのですが、仮に
シート1で
Range("A1").AutoFilter Field:=1, Criteria1:="○"
で、オートフィルタをかけたとします。
この際の可視セルがA1〜J1セル、D1セル〜J1セルになり、B1〜J1は非可視になるとします。
この状態で、シート2の規則的なセルへデータをコピーしたいと考えています。
具体的には
シート1のA1セル⇒シート2のD1セル
シート1のA5セル⇒シート2のD2セル
シート1のA6セル⇒シート2のD4セル
シート1のC1セル⇒シート2のE1セル
シート1のC5セル⇒シート2のE2セル
シート1のC6セル⇒シート2のE4セル
・
・
・
といった感じです。
実際にはR1C1形式（cells）で書いており、ループ文等で規則的な貼り付けを実施したいと考えています。
ただ、do while文やFor文で書くと、非可視セルまでデータを取ってしまうので使えません（よね・・・）。
可視セルのみをコピーするやり方は調べればあったのですが、可視セルをそのまま別シートにコピーするというのはわかりましたが、このようにセル単位でコピーする方法がわかりませんでした。
何か良い知恵をお貸ししていただけませんでしょうか。
コードがなくて申し訳ありませんが、よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
＞ この際の可視セルがA1〜J1セル、D1セル〜J1セルになり、B1〜J1は非可視になるとします。 A列でフィルタした場合ですよね？ 非表示になるのは列じゃなくて、行では？ この一文では、さっぱり意味が判りません。
とりあえず、マクロならば、Rows(1).Hidden を調べれば、行が非表示になっているか判定できるので、全行ループしつつ、表示されているものだけ処理するコーディングにできる事でしょう。
（???） 2017/12/21(木) 17:28
提示された例からは、規則性が理解できません。
＞このようにセル単位でコピーする方法がわかりませんでした。
A列でフィルタ、 B列セルを１セルずつ取り出す例
Option Explicit
Sub test()
Dim r As Range
Dim c As Range
Dim n As Long
With Sheets("sheet1").Range("a1").CurrentRegion
.AutoFilter Field:=1, Criteria1:="○"
Set r = .Columns(2).SpecialCells(xlCellTypeVisible)
.AutoFilter
End With
For Each c In r
MsgBox c.Value
Next
End Sub
（マナ） 2017/12/21(木) 18:31
オートフィルタしただけなら行単位で可視／不可視になるだけですよね
さらに、セル範囲「A1〜J1」に「D1〜」も「B1〜」も内包されてますから意味が通じないです。
＞可視セルのみをコピーするやり方は調べればあったのですが、可視セルをそのまま別シートに
＞コピーするというのはわかりましたが、このようにセル単位でコピーする方法がわかりませんでした。
可視セルとセル単位の違いもよくわからないですけど単純に作業シートとして新規シート追加して、フィルタ結果を貼り付け、欲しいデータとったら、作業シートを削除
でどうですか？
（もこな２） 2017/12/22(金) 01:57
まず「定義」というシートと「記入先」というシートがあります。
定義シートA列は「印刷」という表題で、A2以降には「○」が入ったり入らなかったります。
定義シートB列は「区分」という表題で、B2以降にh「AやB」といったアルファベットが1文字入ります。
定義シートC列は「年度」という表題で、B2以降にh「28年度」や「29年度」といった年度の文字列が入ります。
ここで、VBAでA列で「○」がついている、行の「区分」・「年度」を「記入先」シートに転記して、最終的には印刷したいのです。
定義シートのひとつ目に「○」が見つかった行の「区分」は記入先シートのA1へ必ず記載します。
定義シートのひとつ目に「○」が見つかった行の「年度」は記入先シートのA2へ必ず記載します。
次に、定義シートのふたつ目に「○」が見つかった行の「区分」は記入先シートのB1へ必ず記載します。
定義シートのふたつ目に「○」が見つかった行の「年度」は記入先シートのB1へ必ず記載します。
・この時点で印刷をします。
（本当なら、ここで「記入先」シートのデータを消したいのですが割愛します）
次に、定義シートのみっつ目に「○」が見つかった行の「区分」は記入先シートのA1へ必ず記載します。
定義シートのみっつ目に「○」が見つかった行の「年度」は記入先シートのA2へ必ず記載します
この時点で印刷をします。
次に、定義シートのよっつ目に「○」が見つかった行の「区分」は記入先シートのB1へ必ず記載します。
定義シートのよっつ目に「○」が見つかった行の「年度」は記入先シートのB2へ必ず記載します
・この時点で印刷をします。
・
・
・
この繰り返し処理となります。
以下のようなマクロを作成しました。
幸いスレッドのタイトルに関しましては、???様の
＞とりあえず、マクロならば、Rows(1).Hidden を調べれば、行が非表示になっているか判定できるので、全＞行ループしつつ、表示されているものだけ処理するコーディングにできる事でしょう。
で解決いたしました・・・が、記入先への転記でFor分を重ねているため、転記がうまくいっていません。
記入先シートのA列とB列に、定義シートで見つかった一つ目の行の「○」の値が書き込まれた後、次に定義シートで見つかった二つ目の行の「○」の値が書き込まれます。
本来であれば、私の頭の中では「定義シート」の○が見つかった1行目の「区分」が「記入先」シートのA1へ、次に「年度」がA2へ転記され・・・
次に、「定義シート」の○が見つかった2行目の「区分」が「記入先」シートのB1へ、次に「年度」がB2へ転記され・・・
次に、3つ目に見つかったものは、A1、A2へ上書き・・・
というループを考えていました。
以下のようなマクロです
Option Explicit
Sub TEST3()
Dim Kubun, Nendo As Range
Dim i, j, KubunC, NendoC, LastRow As Long
'デバッグ用
ThisWorkbook.Worksheets("記入先").Activate
With Worksheets("定義")
'区分の列番号の取得
Set Kubun = .Cells.Find(What:="区分", LookAt:=xlWhole)
KubunC = Kubun.Column
'年度の列の列番号取得
Set Nendo = .Cells.Find(What:="年度", LookAt:=xlWhole)
NendoC = Nendo.Column
'オートフィルタでA行の「印刷」という行に「○」がついているものを印刷する
.Range("A1").AutoFilter Field:=1, Criteria1:="○"
'定義シートの最終行を取得
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
'もし可視セルならば処理をする
If Rows(i).Hidden = False Then
For j = 1 To 2
'区分の記入
Worksheets("記入先").Cells(1, j) = .Cells(i, KubunC).Value
'年度の記入
Worksheets("記入先").Cells(2, j) = .Cells(i, NendoC).Value
If j = 2 Then
Worksheets("記入先").PrintPreview
End If
Next j
End If
Next i
End With
End Sub
シート「定義」
印刷 区分 年度
○ A 29
○ B 29
シート「記入先」
空白
かなりスレッド違いの名前の質問内容が変わってしま申し訳ないのですが、知恵をお貸し願えませんでしょうか。
かなり稚拙なマクロをお見せし、長文になってしまい申し訳ございません。
（まっくん） 2017/12/22(金) 14:26
こにちわ、まっくんです。
すいません、かなり抽象的な書き方をしてしまい、皆様をご混乱させつぃまいまして申し訳ございません。
いま、私がやりたいことは、
まず「定義」というシートと「記入先」というシートがあります。
定義シートA列は「印刷」という表題で、A2以降には「○」が入ったり入らなかったります。
定義シートB列は「区分」という表題で、B2以降にh「AやB」といったアルファベットが1文字入ります。
定義シートC列は「年度」という表題で、B2以降にh「28年度」や「29年度」といった年度の文字列が入ります。
ここで、VBAでA列で「○」がついている、行の「区分」・「年度」を「記入先」シートに転記して、最終的には印刷したいのです。
定義シートのひとつ目に「○」が見つかった行の「区分」は記入先シートのA1へ必ず記載します。
定義シートのひとつ目に「○」が見つかった行の「年度」は記入先シートのA2へ必ず記載します。
次に、定義シートのふたつ目に「○」が見つかった行の「区分」は記入先シートのB1へ必ず記載します。
定義シートのふたつ目に「○」が見つかった行の「年度」は記入先シートのB1へ必ず記載します。
・この時点で印刷をします。
（本当なら、ここで「記入先」シートのデータを消したいのですが割愛します）
次に、定義シートのみっつ目に「○」が見つかった行の「区分」は記入先シートのA1へ必ず記載します。
定義シートのみっつ目に「○」が見つかった行の「年度」は記入先シートのA2へ必ず記載します
この時点で印刷をします。
次に、定義シートのよっつ目に「○」が見つかった行の「区分」は記入先シートのB1へ必ず記載します。
定義シートのよっつ目に「○」が見つかった行の「年度」は記入先シートのB2へ必ず記載します
・この時点で印刷をします。
・
・
・
この繰り返し処理となります。
以下のようなマクロを作成しました。
幸いスレッドのタイトルに関しましては、???様の
＞とりあえず、マクロならば、Rows(1).Hidden を調べれば、行が非表示になっているか判定できるので、全＞行ループしつつ、表示されているものだけ処理するコーディングにできる事でしょう。
で解決いたしました・・・が、記入先への転記でFor分を重ねているため、転記がうまくいっていません。
記入先シートのA列とB列に、定義シートで見つかった一つ目の行の「○」の値が書き込まれた後、次に定義シートで見つかった二つ目の行の「○」の値が書き込まれます。
本来であれば、私の頭の中では「定義シート」の○が見つかった1行目の「区分」が「記入先」シートのA1へ、次に「年度」がA2へ転記され・・・
次に、「定義シート」の○が見つかった2行目の「区分」が「記入先」シートのB1へ、次に「年度」がB2へ転記され・・・
次に、3つ目に見つかったものは、A1、A2へ上書き・・・
というループを考えていました。
以下のようなマクロです
Option Explicit
Sub TEST3()
Dim Kubun, Nendo As Range
Dim i, j, KubunC, NendoC, LastRow As Long
'デバッグ用
ThisWorkbook.Worksheets("記入先").Activate
Cells.Clear
With Worksheets("定義")
'区分の列番号の取得
Set Kubun = .Cells.Find(What:="区分", LookAt:=xlWhole)
KubunC = Kubun.Column
'年度の列の列番号取得
Set Nendo = .Cells.Find(What:="年度", LookAt:=xlWhole)
NendoC = Nendo.Column
'オートフィルタでA行の「印刷」という行に「○」がついているものを印刷する
.Range("A1").AutoFilter Field:=1, Criteria1:="○"
'定義シートの最終行を取得
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
For i = 2 To LastRow
'もし可視セルならば処理をする
If Rows(i).Hidden = False Then
'区分の記入
Worksheets("記入先").Cells(1, j) = .Cells(i, KubunC).Value
'年度の記入
Worksheets("記入先").Cells(2, j) = .Cells(i, NendoC).Value
End If
Next i
Next j
End With
End Sub
シート「定義」
印刷 区分 年度
○ A 28
○ B 29
● C 30
シート「記入先」
空白
かなりスレッド違いの名前の質問内容が変わってしま申し訳ないのですが、知恵をお貸し願えませんでしょうか。
かなり稚拙なマクロをお見せし、長文になってしまい申し訳ございません。
（まっくん） 2017/12/22(金) 14:49
Option Explicit
Sub TEST3()
Dim Kubun, Nendo As Range
Dim i, j, KubunC, NendoC, LastRow As Long
'デバッグ用
ThisWorkbook.Worksheets("記入先").Activate
Cells.Clear
With Worksheets("定義")
'区分の列番号の取得
Set Kubun = .Cells.Find(What:="区分", LookAt:=xlWhole)
KubunC = Kubun.Column
'年度の列の列番号取得
Set Nendo = .Cells.Find(What:="年度", LookAt:=xlWhole)
NendoC = Nendo.Column
'オートフィルタでA行の「印刷」という行に「○」がついているものを印刷する
.Range("A1").AutoFilter Field:=1, Criteria1:="○"
'定義シートの最終行を取得
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 2
For i = 2 To LastRow
'もし可視セルならば処理をする
If .Rows(i).Hidden = False Then
'区分の記入
Worksheets("記入先").Cells(1, j) = .Cells(i, KubunC).Value
'年度の記入
Worksheets("記入先").Cells(2, j) = .Cells(i, NendoC).Value
End If
Next i
Next j
End With
End Sub
（まっくん） 2017/12/22(金) 16:40
行の表示・非表示を判定しなくても
A列が○かどうかを判定すればよいだけでは？
（マナ） 2017/12/22(金) 17:49
＜記入先＞シート
１行目からデータ部
A列から順に[区分][年度]
＜やりたいこと＞（ちょっと解釈を変えてます）
「定義」のA列に〇がついているものを抽出して、B〜Cを行列を入れ替えて記入先に貼り付けて印刷
ただし、２列ごとに印刷（あとは非表示）で印刷したい
ってことでしょうか？
また、途中で「記入先」のデータを消したいとのコメントがあるので、印刷さえされれば「記入先」シートがどんな状態でもいいってことでしょうか？
以下はその場合のコメントですが、
作戦１
(1)「記入先」をクリア
(2)オートフィルタを使ってＡ列に〇が入ってるのを抽出
(3)抽出されたデータを、作業シートを作成してそこにコピペ
(4)作業シートの内容をコピーして「記入先」に行列入れ替えで貼り付け
(5)作業シートを削除
(6)「記入先」の２列ごとに改ページを挿入
(7)印刷実行
作戦２（マナさんがコメントされてることとかぶりますが）
(1)「記入先」をクリア
(2)「定義」のＡ列を２行目から最終行まで順番に見て行って
〇がついていればB〜C列を「記入先」の1〜２行目に
列をずらしながら出力
(3)作戦１の(6)以降と一緒
このどちらかの作戦で解決されませんか？
このほか細かいことですが
ThisWorkbook.Worksheets("記入先").Activate
Cells.Clear
ここ、いったん「記入先」をアクティブにしてからClearメソッド実行してますが、アクティブにする必要はありません。
むしろ、なんかの拍子に「記入先」がアクティブになってなくても、アクティブシートの全内容をクリアしてしまうのであぶないなぁと思います。
（わかってやってるなら止めませんが）
（もこな２） 2017/12/23(土) 10:56
Option Explicit
Sub test2()
Dim ws As Worksheet
Dim i As Long
Dim 次の転記 As String
Dim 印刷する As Boolean
Set ws = Worksheets("定義")
次の転記 = "A"
For i = 2 To 10
If ws.Cells(i, "A").Value = "○" Then
MsgBox i & "行を" & 次の転記 & "列に転記"
If 次の転記 = "A" Then
If i = 10 Then 印刷する = True
次の転記 = "B"
Else
印刷する = True
次の転記 = "A"
End If
If 印刷する Then
MsgBox "印刷してから値クリア"
印刷する = False
End If
End If
Next
End Sub
（マナ） 2017/12/23(土) 12:32
（マナ） 2017/12/23(土) 15:09
Option Explicit
Sub test3()
Dim ws As Worksheet
Dim i As Long
Dim 次の転記 As String
Dim 印刷する As Boolean
Set ws = Worksheets("定義")
次の転記 = "A"
For i = 2 To 10
If ws.Cells(i, "A").Value = "○" Then
MsgBox i & "行を" & 次の転記 & "列に転記"
If 次の転記 = "A" Then
次の転記 = "B"
印刷する = True
Else
MsgBox "印刷してから値クリア"
印刷する = False
次の転記 = "A"
End If
End If
Next
If 印刷する Then
MsgBox "印刷してから値クリア"
End If
End Sub
（マナ） 2017/12/23(土) 15:20
ここまで丁寧に教えていただいているのですが、やはりうまくいきません。
もこな2様のおっしゃっているのは、「○」のついている行を「1行づつ、作業シートへコピーする」ということでしょうか？
この場合でも、可視行の
「i行目の情報を行列変換する」で、複数行にまたがってループでコピーする際うまくいきません。（私の例では3行でしたが、これが1000行あると考えてください）
マナ様の例だと、すいません、私の頭では理解ができませんでした。
大変厚かましいようですが、実際のシートコピーをどのようにするかご教授願えませんでしょうか。
スキル不足でご迷惑をおかけいたしまして申し訳ありません。
よろしくお願い申し上げます。
（まっくん） 2017/12/26(火) 15:14
こちらで、色々話をしていて、最終的にはこういう形にしたいということになりました。
転記元
ワークシート名 「定義」
区分 年度 書類名 重要度 印刷
A 25 契約 1 ○
A 28 参考 1
B 29 契約 3 ○
A 30 契約 2 ○
C 29 参考 1 ○
A 29 資料 3
・
・
・
行数不確定
転記先
ワークシート名
「記入先」
A 1 B 1 A
列 列 契約 あ 契約 あ 契約 1 け 3 け 2 ○ る ○ る ○
という形になり、「記入先」ワークシートには「年度」を入れなくなります。（ただし、「定義」ワークシートにはDB的な意味で残しておきたい）
そして、「記入先」ワークシートで、3列分転記入力されると、データを印刷した後、データをクリアし、再度「定義」ワークシートから同様に○のついている行のデータを上記の表のように転記させ印刷、データクリア・・・といった流れになります。
すいませんが、知恵をお貸し願えませんでしょうか・・・。
（まっくん） 2017/12/26(火) 16:08
＞もこな2様のおっしゃっているのは、「○」のついている行を「1行づつ、作業シートへコピーする」
＞ということでしょうか？
違います。
作戦１はオートフィルターを使う代わりに作業シートを利用します。
作戦２は「○」のついている行を1行づつ読み取って行列を入れ替えた上で「記入先」シートに行をずらしながら直接出力します。
＞この場合でも、可視行の
＞「i行目の情報を行列変換する」で、複数行にまたがってループでコピーする際うまくいきません。
＞（私の例では3行でしたが、これが＞1000行あると考えてください）
どちらの作戦で、どのようにうまくいかないのか、の情報がないので回答できません。
（1000列を２列ずつ改ページ入れていくという処理を考えると、エラーが出そうな気も
しますが、どのようなエラーが発生しているのか、確認してからでも遅くはないと
おもいますので今回は説明を割愛します。）
（もこな２） 2017/12/26(火) 18:11
誤 「記入先」シートに行をずらしながら直接出力します。
正 「記入先」シートに列をずらしながら直接出力します。
（もこな２） 2017/12/26(火) 18:16
定義シート
区分 年度 書類名 重要度 印刷
A 25 契約 1 ○
A 28 参考 1
B 29 契約 3 ○
A 30 契約 2
C 29 参考 1 ○
A 29 資料 3
他、「記入先」シート⇒空白
「作業シート」⇒空白
からスタートします。
Option Explicit
Sub TEST3()
Dim Kubun, Nendo As Range
Dim i, j, KubunC, NendoC, LastRow, LastCol As Long
Dim WS, WS2, WS3 As Worksheet
Set WS = Worksheets("定義")
Set WS2 = Worksheets("記入先")
Set WS3 = Worksheets("作業シート")
With WS
'定義シートの最終行を取得
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'定義シートの最終列を取得
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LastRow
If .Cells(i, 5) = "○" Then
.Range(.Cells(i, 2), .Cells(i, LastCol)).Copy
WS3.Cells(1, i).PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
For j = 1 To 6 Step 2
WS2.Cells(2, j) = WS3.Cells(1, i)
WS2.Cells(3, j).Offset(1, 0) = WS3.Cells(2, i)
Next j
End If
Next i
End With
End Sub
問題点1：まず、作業シートで、定義シートに「○」がついていないところは行が空白になります。
25 29 29
契約 契約 参考
1 3 1
○ ○ ○
のような感じで、間にセルが入ってしまいます。
問題点2：
上記のマクロを走らせると、
29 29 29
参考 参考 参考
という形で、記入先シートには出力されてしまいます。（最後に○がついている行のみ出力されている）
問題がどこにあるかはわかっています。
ただ、それをマクロで書くとどうなるのかが全く分かりません。
問題点1：の問題は
For i = 1 To LastRow が回るため、 If .Cells(i, 5) = "○" に引っかからなくても、空白が1列空いてしまうためです。
問題点2：の問題は
For j = 1 To 6 Step 2
WS2.Cells(2, j) = WS3.Cells(1, i)
WS2.Cells(3, j).Offset(1, 0) = WS3.Cells(2, i)
Next j
は
For i = 1 To LastRow
内にあるため、最終的な値のみ、記入先シートには記載されてしまいます。
という問題点把握を自分なりにしています。
すいません、解決方法はありますでしょうか・・・。
何度もすいませんが、教えていただけませんでしょうか。
よろしくお願い申し上げます。
（まっくん） 2017/12/27(水) 12:23
＞Dim WS, WS2, WS3 As Worksheet
↑は記述の仕方間違っています。
＞すいません、私の頭では理解ができませんでした。
わたしの案は、もこな２さんのと違って効率悪いかもしれませんが
たぶん、印刷が律速になると思うので、処理速度は求めませんよね？
なので、単純に全行を１行ずつ調べながら転記するというものです。
で、１行転記するごとに、「次の転記」先A→C→Eと変えています。
印刷データがちょうど３の倍数でない場合にも、
印刷されないで終わると困るので、
変数「印刷する」で判断できるようにしています。
変数を使わずに、「A1セルが空白でないなら印刷」
というのでもOKです。
Sub test3()
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long
Dim 次の転記 As String
Dim 印刷する As Boolean
Set ws = Worksheets("定義")
Set ws2 = Worksheets("記入先")
次の転記 = "A"
For i = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "E").Value = "○" Then
ws2.Cells(1, 次の転記).Value = ws.Cells(i, "C").Value
ws2.Cells(2, 次の転記).Value = ws.Cells(i, "D").Value
If 次の転記 = "A" Then
印刷する = True
次の転記 = "C"
ElseIf 次の転記 = "C" Then
印刷する = True
次の転記 = "E"
Else
ws2.PrintPreview
ws2.Range("A1:A2,C1:C2,E1:E2").ClearContents
印刷する = False
次の転記 = "A"
End If
End If
Next
If 印刷する Then
ws2.PrintPreview
ws2.Range("A1:A2,C1:C2").ClearContents
End If
End Sub
（マナ） 2017/12/27(水) 20:34
このほうが、わかりやすいし、よかったかもしれません。
Sub test4()
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long
Dim 次の転記 As String
Set ws = Worksheets("定義")
Set ws2 = Worksheets("記入先")
次の転記 = "A"
For i = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "E").Value = "○" Then
ws2.Cells(1, 次の転記).Value = ws.Cells(i, "C").Value
ws2.Cells(2, 次の転記).Value = ws.Cells(i, "D").Value
If 次の転記 = "A" Then
次の転記 = "C"
ElseIf 次の転記 = "C" Then
次の転記 = "E"
Else
ws2.PrintPreview
ws2.Range("A1:A2,C1:C2,E1:E2").ClearContents
次の転記 = "A"
End If
End If
Next
If ws2.Range("A1").Value <> "" Then
ws2.PrintPreview
ws2.Range("A1:A2,C1:C2").ClearContents
End If
End Sub
（マナ） 2017/12/27(水) 20:44
ちなみに、まっくんさんは配列ってわかりますか？
もしわかるのであれば、下記のようなやり方もありますので、検討してみてください。
※ちなみに３アイテムごとに印刷っていうのが意外と難しくて悩んでます。
（出来ないわけじゃ無いんですが、どうにも美しくない。。。）
まぁとりあえず提供します。（出力処理までテスト済み、印刷は未チェック）
Sub Sample()
'==変数宣言とか
Dim 配列変数() As String
Dim i As Long, c As Integer
Dim Wf As Object
Set Wf = Application.WorksheetFunction
'==データの取込(「定義」シートのE列が「○」なら配列変数に格納)
With Worksheets("定義")
If Not Wf.CountIf(.Range("E:E"), "○") >= 1 Then Exit Sub
ReDim 配列変数(Wf.CountIf(.Range("E:E"), "○"), 3)
c = 0 'カウンタを０にセット（配列変数の第1要素のカウンタとして使用）
For i = 2 To .Cells(.Rows.Count, "E").End(xlUp).Row
If .Cells(i, "E") = "○" Then
配列変数(c, 0) = .Range("A" & i).Value
配列変数(c, 1) = .Range("C" & i).Value
配列変数(c, 2) = .Range("D" & i).Value
配列変数(c, 3) = .Range("E" & i).Value
c = c + 1
End If
Next i
End With
'==データの出力(と印刷)
With Worksheets("記入先")
'−−出力処理
.Cells.Clear '「記入先」シートの全セルをクリア
c = 1 'カウンタを1にリセット（列番号として使用）
For i = 0 To UBound(配列変数, 1)
.Cells(1, c).Value = 配列変数(i, 0)
.Cells(2, c).Value = 配列変数(i, 1)
.Cells(3, c).Value = 配列変数(i, 2)
.Cells(4, c).Value = 配列変数(i, 3)
c = c + 2
Next i
'−−印刷処理
'６列セットの印刷を何回繰り返せば良いかを計算
'考え方：１列目〜 （配列変数の第１要素に格納されているアイテム数 ×２ ）列目までが印刷範囲
' これを６列ずつ印刷 なので 上記を６で除して切り上げが印刷回数
For i = 0 To Application.RoundUp(((UBound(配列変数, 1) + 1) * 2) / 6) - 1
.Range(.Column(1 + (i * 6)), .Column(6 + (i * 6))).PrintOut
Next i
End With
End Sub
（もこな２） 2017/12/27(水) 22:57
.Range(.Cells(i, 2), .Cells(i, LastCol)).Copy
WS3.Cells(1, i).PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
ってあるので、「○」じゃないやつがでもiが進んじゃうから歯抜けデータが
完成するんじゃないかとおもいます。（ご自身でも気づかれているようですが）
(3) 問題点２のほうは、(1)のとおり作業シート要らないって考えれば問題解決しません？
とりあえず、いくつかの私の回答まとめると、
(1)オートフィルタを使うんじゃ無くて、E列に○が付いてるということを条件に処理したらよさそう
(2)３アイテムコピーして、印刷して、クリアしてを繰り返すより、一度出力してから３アイテムごとに印刷したほうがよさそう（コードの書きやすさや考え方の面で）
って思いました。
もちろんやり方はいろいろありますので、ご自身に合ったやり方を見つけてください。
このほか、余談ですけど、「○」がついてればって処理ってある意味危険ですよ。入力を他の人にお願いする場合や、他の方にマクロ付きブックを引き継ぐ場合、数字の０を全角で入れてくる人や、●や◎入れてくる人もいるかもしれないので、将来的には、ブランクじゃななきゃ処理する〜みたいな感じに修正されたほうがいいかもしれません。
他の掲示板でちょっと話題になったことがありましたので、ご参考まで。
（もこな２） 2017/12/27(水) 23:20
今からコメントマクロの方を解析させていただきつつ勉強させていただきます。
また、わなからないところがあれば（たぶんあるでしょう・・・）ご質問をさせていただくことをご容赦ください。
（まっくん） 2017/12/28(木) 09:19
また、配列を使わない＆印刷処理でもうちょっとマシな方法を思いついたので追加投稿します。
コードの下に簡単な解説つけときました。
Sub Sample2()
'==前処理（変数宣言とか）
Dim 出力列 As Long, 印刷始 As Long
Dim MyRange As Range
Dim 出力SH As Worksheet
Set 出力SH = Worksheets("記入先")
出力SH.Cells.Clear '--(1)
'==主処理１（抽出＆コピー）
With Worksheets("定義")
出力列 = 1 '--(2)
For Each MyRange In .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp)) '--(3)
If MyRange.Value <> "" Then '--(4)
.Cells(MyRange.Row, "A").Copy 出力SH.Cells(1, 出力列)
.Cells(MyRange.Row, "C").Copy 出力SH.Cells(2, 出力列)
.Cells(MyRange.Row, "D").Copy 出力SH.Cells(3, 出力列)
.Cells(MyRange.Row, "E").Copy 出力SH.Cells(4, 出力列)
出力列 = 出力列 + 2 '--(5)
End If
Next MyRange
End With
'==主処理２（印刷）
With 出力SH
印刷始 = 1
Do Until 印刷始 > .Cells(1, .Columns.Count).End(xlToLeft).Columns '--(6)
.Range(.Columns(印刷始), .Columns(印刷始 + 5)).PrintOut
印刷始 = 印刷始 + 6
Loop
End With
'==後処理（省略可能）
Set MyRange = Nothing
Set 出力SH = Nothing
End Sub
（1）ここで、「記入先」シートの全セルをクリアしています。
（2）ループの外側で変数「出力列」の初期値をセットしています。
（3）For Eachで「定義」シートのセル範囲「E2〜E○」を１セルずつ取り出して処理します
（4）(3)で取り出したセルの値がブランクで無ければ処理行うという意味になります。
（5）変数「出力列」に（１列おきだから）２を加算して、次のコピー処理に備えます
（6）変数「印刷始」が「記入先」シートの（１行目の）最終列を超えるまで印刷を繰り返します
（もこな２） 2017/12/28(木) 11:19
私の要望でした
「3列分印刷したのち、データをクリアして、再度3列分転記して印刷・・・（以下繰り返し」
というのができていないような気がします・・・。
マクロを動作させてみたところ、転記したデータは右にどんどん流れて行っているように見受けられました。（印刷自体は1ページに3列分というようにはなっていましたが・・・）
仮に定義シートのE列にブランク以外が1000行ほどあると対応できないのではないでしょうか・・・。
どこかで、
１．記入先シートをクリア
２．印刷始を1に戻す
という処理が必要になってくるのではないでしょうか。
すいません、私の考えちがえでしたら申し訳りません。
よろしくお願い申し上げます。
（まっくん） 2017/12/28(木) 13:55
＞１．記入先シートをクリア
＞２．印刷始を1に戻す
＞という処理が必要になってくるのではないでしょうか。
もちろん、そういった考え方もあるとおもいます。
このスレッドにあるヒントで実現可能とおもわれますので、頑張ってご自身で作ってみましょう。
（もこな２） 2017/12/28(木) 14:44
おっしゃるとおりで、かなりヒントは頂いているともいます。
できるだけ頑張ってみます！
（まっくん） 2017/12/28(木) 16:05
Sub Sample2()
'==前処理（変数宣言とか）
Dim 出力列 As Long, 印刷始 As Long
Dim MyRange As Range
Dim 出力SH As Worksheet
Set 出力SH = Worksheets("記入先")
出力SH.Cells.Clear '--(1)
'==主処理１（抽出＆コピー）
With Worksheets("定義")
出力列 = 1 '--(2)
For Each MyRange In .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp)) '--(3)
If MyRange.Value <> "" Then '--(4)
.Cells(MyRange.Row, "A").Copy 出力SH.Cells(1, 出力列)
.Cells(MyRange.Row, "C").Copy 出力SH.Cells(2, 出力列)
.Cells(MyRange.Row, "D").Copy 出力SH.Cells(3, 出力列)
.Cells(MyRange.Row, "E").Copy 出力SH.Cells(4, 出力列)
出力列 = 出力列 + 2 '--(5)
If 出力列 = 7 Then
出力SH.PrintPreview
出力列 = 1
出力SH.Cells.Clear
End If
End If
Next MyRange
End With
ヒントをたくさんいただきまして、上記でうまくいった（様な気がします）とおもいます。
今から、色々と入ったDBに展開して、うまくいくかどうかを検証してみます！
（まっくん） 2017/12/28(木) 16:37
もこな2さんの指摘の「3で割り切れない」というのは、つまり出力列が「3」や「5」で終わってしまう場合、私のやり方だと印刷されないということですよね（とステップインしながら勝手に判断しました）
もし私の解釈が的を得ているならば、確かに、
出力列が3でも5でも印刷されるような工夫をしないといけませんね。
で、その工夫を考えています。
少し頭を柔軟にして、マナ様のマクロも参考にさせて頂き、考えてみます。
（まっくん） 2017/12/29(金) 01:01
そうです。
マナさんが投稿された
2017/12/27(水) 20:34 のコメントと
2017/12/27(水) 20:44 のコードにヒントというか答えがあるとおもいますので、確認されてはいかがでしょうか。
（もこな２） 2017/12/29(金) 10:57
一応下記のマクロでうまくいっている（様子）です(^^;
Sub Sample2()
Dim 出力列 As Long
Dim MyRange As Range
Dim 出力SH As Worksheet
Set 出力SH = Worksheets("記入先")
出力SH.Cells.Clear
With Worksheets("定義")
出力列 = 1
For Each MyRange In .Range(.Cells(2, "E"), .Cells(.Rows.Count, "E").End(xlUp))
If MyRange.Value <> "" Then '--(4)
.Cells(MyRange.Row, "A").Copy 出力SH.Cells(1, 出力列)
.Cells(MyRange.Row, "C").Copy 出力SH.Cells(2, 出力列)
.Cells(MyRange.Row, "D").Copy 出力SH.Cells(3, 出力列)
.Cells(MyRange.Row, "E").Copy 出力SH.Cells(4, 出力列)
If 出力列 = 1 Then
出力列 = 出力列 + 2
ElseIf 出力列 = 3 Then
出力列 = 出力列 + 2
Else
出力SH.PrintPreview
出力SH.Cells.Clear
出力列 = 1
End If
End If
Next MyRange
If 出力SH.Cells(1, 1) <> "" Then
出力SH.PrintPreview
出力SH.Cells.Clear
End If
End With
End Sub
もこな2様からいただいたマクロとマナ様からいただいたマクロを組み合わせた結果です。
Next Myrangeを
If 出力SH.Cells(1, 1) <> "" Then
出力SH.PrintPreview
出力SH.Cells.Clear
End If
の前に持ってくることに、なかなか気が付きませんでした（マナさんんがあそこまで答えを出していてくれたのに(^^;）
ご指導いただきました、マナ様・もこな2様に、大変厚かましいようなご質問ですが・・・
正解でしょうか？
よろしくお願い申し上げます。
（まっくん） 2017/12/30(土) 02:48
わたしなら、
With Worksheets("定義")は使わないで
SET 定義SH=Worksheets("定義")
にするかもしれません。
努力家のようですので、もし時間があればですが、
Wordの差し込み印刷について勉強してみるのもよいと思います。
今回のようなことが、マクロを使わなくても簡単にできます。
フォーマットの変更にも対応しやすいのでオススメです。
（マナ） 2017/12/30(土) 09:47
気になる点とすれば、ご心配されているようなE列がブランクでないものが1000件あった場合、
・PrintPreviewだと334回「印刷」ボタンを手動で押すことになる、
・上記が嫌でPrintOutにかえたら、それはそれで印刷されるまで
正しく抽出（印刷）された（される）のか確認する術がない
・ヒットするのがたくさんあって、その一部だけほしい場合、
フラグを立て直す必要がある。
というのが考え付きますので、本当にたくさんのデータを扱うようになりそうなときは、抽出（印刷用データ作成）と印刷実行は別工程にしたほうがいいかなぁと個人的には思います。
（もこな２） 2017/12/30(土) 10:36
お正月前に一区切りついてほっとしました(^^;
＞・PrintPreviewだと334回「印刷」ボタンを手動で押すことになる、
ここは印刷ボタンとプレビューボタンを分けようと思っています。
1ページに3つの要素なので、「○」の数が3つ以上だと「プレビューできません」にしようかと思っています。
印刷ボタンを押してしまった場合ですが・・・。
もう仕方なく、その人の責任なので、ジョブを止めてもらうしかないでしょう。
・上記が嫌でPrintOutにかえたら、それはそれで印刷されるまで
正しく抽出（印刷）された（される）のか確認する術がない
同じ動作の繰り返しなので、まず3つだけ○を入れてもらってプレビューしてもらい、様式等があっているようであれば印刷と考えています。
「定義」シート内の要素が間違っている場合は、人的ミスなので、止めようがないので仕方ないと考えています。
どうもありがとうございました！！！m(_ _)m
（まっくん） 2017/12/30(土) 19:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.