エクセル マクロ：チェックボックス コピー２

質問

昨日質問し、解決したと思ったのですが、データ量とチェックボックスの数を増やしたら
エラーが出てしまいました。解決策を教えてください。

sheet1にはデータがあり行数は25000です。（行数は変動で行数MAXだったりもします）
sheet2にはチェックボックス20個とコマンドボタンがあります。
下記のマクロでは17個までチェックしてもコピー出来ましたが、18個目からエラーが出ました。

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

Private Sub CommandButton1_Click()

Dim myrange As String
Dim rmax As Long
rmax = Sheets("sheet1").Range("B1").End(xlDown).Row
With Sheets("sheet2")
If .CheckBox1 Then myrange = myrange & ",$B$1:$B$" & rmax
If .CheckBox2 Then myrange = myrange & ",$C$1:$C$" & rmax
If .CheckBox3 Then myrange = myrange & ",$D$1:$D$" & rmax
If .CheckBox4 Then myrange = myrange & ",$E$1:$E$" & rmax
If .CheckBox5 Then myrange = myrange & ",$F$1:$F$" & rmax
If .CheckBox6 Then myrange = myrange & ",$G$1:$G$" & rmax
If .CheckBox7 Then myrange = myrange & ",$H$1:$H$" & rmax
If .CheckBox8 Then myrange = myrange & ",$I$1:$I$" & rmax
If .CheckBox9 Then myrange = myrange & ",$J$1:$J$" & rmax
If .CheckBox10 Then myrange = myrange & ",$K$1:$K$" & rmax
If .CheckBox11 Then myrange = myrange & ",$L$1:$L$" & rmax
If .CheckBox12 Then myrange = myrange & ",$M$1:$M$" & rmax
If .CheckBox13 Then myrange = myrange & ",$N$1:$N$" & rmax
If .CheckBox14 Then myrange = myrange & ",$O$1:$O$" & rmax
If .CheckBox15 Then myrange = myrange & ",$P$1:$P$" & rmax
If .CheckBox16 Then myrange = myrange & ",$Q$1:$Q$" & rmax
If .CheckBox17 Then myrange = myrange & ",$R$1:$R$" & rmax
If .CheckBox18 Then myrange = myrange & ",$S$1:$S$" & rmax
If .CheckBox19 Then myrange = myrange & ",$T$1:$T$" & rmax
If .CheckBox20 Then myrange = myrange & ",$U$1:$U$" & rmax
End With
If myrange = "" Then
MsgBox "チェックしてください"
Exit Sub
End If
myrange = "$A$1:$A$" & rmax & myrange
Sheets("sheet1").Range(myrange).Copy
Sheets("sheet3").Range("A1").PasteSpecial xlPasteValues
Sheets("sheet3").Select

End Sub

回答No.1

keithin · ベストアンサー

文字列が長すぎるだけです。

private sub CommandButton1_Click()
　dim res as range
　dim rmax as long
　dim i as integer
　dim flg as boolean

　rmax = worksheets("Sheet1").range("B1").end(xldown).row
　set res = worksheets("Sheet1").range("A1:A" & rmax)

　for i = 1 to 20
　　if worksheets("Sheet2").oleobjects("CheckBox" & i).object.value then
　　　set res = union(res, worksheets("Sheet1").range("A1:A" & rmax).offset(0, i))
　　　flg = true
　　end if
　next i

　if not flg then
　msgbox "NO CHECK"
　exit sub
　end if

　res.copy
　worksheets("Sheet3").range("A1").pastespecial paste:=xlpastevalues
　worksheets("Sheet3").select
end sub

お礼

いつもご回答ありがとうございます。
動作も良好で大変助かりました。
今度ともご指導よろしくお願い致します。

回答No.2

tsubuyuki

まぁ、通常は半角で２５５文字までですから、文字数オーバーで間違いなさそうですね。

ご本人ご提示のコードを最大限生かすなら・・

Private Sub CommandButton1_Click()
Dim myrange As String
'Dim rmax As Long '不要？
'rmax = Sheets("sheet1").Range("B1").End(xlDown).Row
With Sheets("sheet2")
If .CheckBox1 Then myrange = myrange & ",B:B"
　　　（中略）
If .CheckBox20 Then myrange = myrange & ",U:U"
End With
If myrange = "" Then
MsgBox "チェックしてください"
Exit Sub
End If
myrange = "A:A" & myrange
Sheets("sheet1").Range(myrange).Copy
Sheets("sheet3").Range("A1").PasteSpecial xlPasteValues
Sheets("sheet3").Select

End Sub

こんな風に、列全体をコピーするようにして、文字数を減らしてやれば良いんじゃないでしょうか？
正直、変数rmaxの存在意義を感じ取れません。
「最大行までコピーするなら列全体をコピーしても結果は同じ」です。
例えば「Ｂ列で見ている最終行よりもＣ列の方が多いケースがある」、
と言うなら必要かもしれませんが、それが無いのであれば、これは無意味です。

仮にそれがあったとしても、それならそれで
「sheet3に貼り付けた後に、取得した最大行以下を削除」
してやれば結果は同じですね。
例えば
　　　　Sheets("sheet3").Rows(rmax + 1 & ":" & Rows.Count).Delete
こんな感じのものを末尾に足してやればＯＫです。

やり方はいくらでもありますと言う事で、参考までに。

お礼

ご回答ありがとうございます。
コードをコピーして使わせて頂きましたが、改善前の場所と同じSheets("sheet1").Range(myrange).Copyのところでエラーがでてしまいました。
マクロ初心者なので原因は分からず、お返事が遅れて申し訳ございませんでした。
今後ともよろしくお願いします。