こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

マクロの改ページの追加について。

下記コードに、E列を上から見て値が変わったら改ページ、を追加したいのですが、上手くできません。
A列、D列のみの下記コードでは成功します。

ちなみにE列は日付なんですが、A列D列同様にコードを書き足すだけではダメなんでしょうか??

以前こちらで質問させて頂いて、回答を頂いたコードで、私自身完璧に内容を理解できていないので、追加の仕方もわからない状況です。

よろしくお願い致します。

Sub test()
Dim rng As Range
Dim objA As New Collection
Dim objD As New Collection
Dim strA As String
Dim strD As String
Dim blnBreak As Boolean

' 改ページを全て解除
Activesheet.ResetAllPageBreaks

Activesheet.PageSetup.PrintArea ="$A:$K"

For Each rng In Range("A:A")
strA = CStr(rng.Value)
strD = CStr(rng.Offset(0, 3).Value)

' コレクションに追加(同じデータはスキップする)
On Error Resume Next
objA.Add strA, strA
objD.Add strD, strD
On Error GoTo 0

If objA.Count = 2 Then
' A列の 2つ目のコレクションで改ページ
blnBreak = True

' コレクションをリセット
Set objA = New Collection
Set objD = New Collection

objA.Add strA, strA
objD.Add strD, strD
Else
If objD.Count = 4 Then
' D列の 4つ目のコレクションで改ページ
blnBreak = True

' コレクションをリセット
Set objA = New Collection
Set objD = New Collection

objA.Add strA, strA
objD.Add strD, strD
Else
blnBreak = False
End If
End If

' 改ページ挿入
If blnBreak Then
Activesheet.HPageBreaks.Add rng
End If
Next
End Sub

投稿日時 - 2020-09-25 19:14:57

QNo.9803773

困ってます

質問者が選んだベストアンサー

No.2 です.
今後,他の条件が加わることも想定して,コレクションをリセットする処理を ResetCollプロシージャにまとめました.
また,パラメータが 6つもありゴチャゴチャするので,モジュールの外に定義しました.

' ----------------------- ここから -----------------------------
Private objA As New Collection
Private objD As New Collection
Private objE As New Collection
Private strA As String
Private strD As String
Private strE As String

Sub test()
Dim rng As Range
Dim blnBreak As Boolean

' 改ページを全て解除
ActiveSheet.ResetAllPageBreaks

ActiveSheet.PageSetup.PrintArea = "$A:$K"

For Each rng In Range("A:A")
' A列に空白が見つかったら終了(A列の途中に空白がある場合は次行を削除してください)
If rng.Value = "" Then Exit For

strA = CStr(rng.Value)
strD = CStr(rng.Offset(0, 3).Value)
strE = CStr(rng.Offset(0, 4).Value)

' コレクションに追加(同じデータはスキップする)
On Error Resume Next
objA.Add strA, strA
objD.Add strD, strD
objE.Add strD, strE
On Error GoTo 0

If objA.Count = 2 Then
' A列の 2つ目のコレクションで改ページ
blnBreak = True

' コレクションをリセット
Call ResetColl
Else
If objD.Count = 4 Then
' D列の 4つ目のコレクションで改ページ
blnBreak = True

' コレクションをリセット
Call ResetColl
Else
If objE.Count = 2 Then
' E列の 2つ目のコレクションで改ページ
blnBreak = True

' コレクションをリセット
Call ResetColl
Else
blnBreak = False
End If
End If
End If

' 改ページ挿入
If blnBreak Then
ActiveSheet.HPageBreaks.Add rng
End If
Next
End Sub

Private Sub ResetColl()
' コレクションをリセット
Set objA = New Collection
Set objD = New Collection
Set objE = New Collection

objA.Add strA, strA
objD.Add strD, strD
objE.Add strE, strE
End Sub
' ----------------------- ここまで -----------------------------

No.4 さんの Orを使った方法だと優先順位がないので,想定される動作にならないように思います(違っていたらごめんなさい).
今後追加される場合は,以下の点に気を付けてトライしてみてください.

(1) 基本的に objA,strAと同じように追加する.
(2) rng.Offset(0, x) で,x はA列から何列ずれているかを考える.
(3) If 分の構造に注意する.
 以下のように入れ子構造で優先順位を設定してください.

If 最優先される条件 Then
blnBreak = True
Call ResetColl
Else
If 2番目に優先される条件 Then
blnBreak = True
Call ResetColl
Else
If 3番目に優先される条件 Then
blnBreak = True
Call ResetColl
Else
If 4番目に優先される条件 Then
blnBreak = True
Call ResetColl
Else
' 最後の条件を満たさなかった場合
blnBreak = False
End If
End If
End If
End If

投稿日時 - 2020-09-26 11:24:43

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.4

質問文に提示されたコード、それに手を入れたNo.3のコード
双方とも、
課題シートの最終行(たぶん1048576行目)までチェックしているため
若干もたつくコードです。

また、
A列のセルを全数チェックするところで
For Each rng In Range("A:A") のコードを使っているため
(経験上問題になったことはないものの)
厳密には、1行目から下方向に順番に処理していることが担保されていません。
詳しくは、よかったら
https://www.exvba.com/2260/
を読んでみてください。

そこで手直しを加え、再ポストします。

なお、示したコードは、
シートの1行目の何れかのセルに値が埋まっている場合のコードです。
(1行目が全数空欄の場合を想定していません。)
1行目が全数空欄の場合はお知らせください。
更に手直しします。


Sub test4()
  
  Dim objA As New Collection
  Dim objD As New Collection
  Dim objE As New Collection
  Dim strA As String
  Dim strD As String
  Dim strE As String
  Dim blnBreak As Boolean
  Dim RowCnt As Long
  
  ' 改ページを全て解除
  ActiveSheet.ResetAllPageBreaks
  
  ActiveSheet.PageSetup.PrintArea = "$A:$K"

  For RowCnt = 1 To ActiveSheet.UsedRange.Rows.Count
    strA = CStr(Cells(RowCnt, 1).Value)
    strD = CStr(Cells(RowCnt, 1).Offset(0, 3).Value)
    strE = CStr(Cells(RowCnt, 1).Offset(0, 4).Value)
    
    ' コレクションに追加(同じデータはスキップする)
    On Error Resume Next
    objA.Add strA, strA
    objD.Add strD, strD
    objE.Add strE, strE
    On Error GoTo 0
    
    If ((objA.Count = 2) Or _
      (objD.Count = 4) Or _
      (objE.Count = 2)) Then
      blnBreak = True
      
      ' コレクションをリセット
      Set objA = New Collection
      Set objD = New Collection
      Set objE = New Collection
    
      objA.Add strA, strA
      objD.Add strD, strD
      objE.Add strE, strE
    Else
     blnBreak = False
    End If
    
    ' 改ページ挿入
    If blnBreak Then
      ActiveSheet.HPageBreaks.Add Cells(RowCnt, 1)
    End If
  Next
  
  MsgBox "終わったよ"
  
End Sub

投稿日時 - 2020-09-26 08:56:56

お礼

ありがとうございます!!

思い通りに改ページが挿入され、助かりました!
やはり、以前よりマクロが完了するまでのスピードが速くなった気がします。

メッセージボックスを使用したことがなく、
完了したときホッコリしました^^

また、何かありましたらよろしくお願いします。

投稿日時 - 2020-09-26 15:30:05

ANo.3

以下のコードで行けるだろうと思います。

Sub test2()
  Dim rng As Range
  Dim objA As New Collection
  Dim objD As New Collection
  Dim objE As New Collection
  Dim strA As String
  Dim strD As String
  Dim strE As String
  Dim blnBreak As Boolean
  
  ' 改ページを全て解除
  ActiveSheet.ResetAllPageBreaks
  
  ActiveSheet.PageSetup.PrintArea = "$A:$K"

  For Each rng In Range("A:A")
    strA = CStr(rng.Value)
    strD = CStr(rng.Offset(0, 3).Value)
    strE = CStr(rng.Offset(0, 4).Value)
    
    ' コレクションに追加(同じデータはスキップする)
    On Error Resume Next
    objA.Add strA, strA
    objD.Add strD, strD
    objE.Add strE, strE
    On Error GoTo 0
    
    If ((objA.Count = 2) Or _
      (objD.Count = 4) Or _
      (objE.Count = 2)) Then
      blnBreak = True
      
      ' コレクションをリセット
      Set objA = New Collection
      Set objD = New Collection
      Set objE = New Collection
    
      objA.Add strA, strA
      objD.Add strD, strD
      objE.Add strE, strE
    Else
     blnBreak = False
    End If
    
    ' 改ページ挿入
    If blnBreak Then
      ActiveSheet.HPageBreaks.Add rng
    End If
  Next
End Sub

投稿日時 - 2020-09-25 22:09:19

ANo.2

No.1 です。
先の回答は忘れてください。
E列の改行条件が判りません。
A列、B列、E列の改行条件を提示してください。

投稿日時 - 2020-09-25 20:44:10

補足

いつもありがとうございます。

全て上から下へ順に見た時です。
A列の値が変わったら改ページ、
D列の値が3回変わったら改ページ、
E列はA列D列の条件をクリアした上で、プラスの条件として、数値(日付)が変わったら改ページ、です。

先ほど頂いた回答でやってみたのですが、E列の改ページ条件が最優先にされてしまったのか、うまく改ページが入りませんでした。

優先順位はA→D→E列の順番です。
Aが最優先です。

文章でわかりずらくて、申し訳ないです。
何かありましたら答えますので、よろしくお願い致します。

投稿日時 - 2020-09-25 21:15:58

ANo.1

A列,D列と同じように E列を追加すれば動くと思いますが.
以下の部分だけは,Offset関数の意味が判っていないと,どうすれば良いのか判らないと思います.

strA = CStr(rng.Value)
strD = CStr(rng.Offset(0, 3).Value)

ここで変数rngには,A列のセルが逐次ループで割り当てられます.
Offset関数は,基準セルから行列方向にずらしたセルを得る関数です.
なので,下記のコードでは rngに A列のセルがあり,Offset(0, 3)はそのセルから行方向に 0行,列方向に 3列ずらしたセル...つまり D列のセルになります.

なので E列のセルであれば,rng.Offset(0, 4)になりますので,
strE = CStr(rng.Offset(0, 4).Value)
を追加すれば良いです.

それ以外は objA,strA と同じように追加すれば良いです.

投稿日時 - 2020-09-25 20:19:37

あなたにオススメの質問