[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Book2の同じ色の行を消して、その最後の2行をBook1に貼り付ける』（パン）
Book2の、同じ色がランダムに付いた行を消してから最終行の2行の一部をコピーして、 あらかじめ開いておいたBook1に貼り付ける、というのをしたいのですが、 真ん中あたりの「r.Select」で「オブジェクト変数または with ブロック変数が設定されていません。」エラーが出て先に進みません。 どう対処すればいいか教えてください。m(_ _)m
http://www.excel.studio-kazu.jp/kw/20091117104756.html ←参考
Dim appExcel As Object
Dim i As Long
Dim s As Long
Dim r As Range
Set appExcel = GetObject("C:\temp\Book2.xlsx")
i = appExcel.Worksheets(1).UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
Application.FindFormat.Interior.Color = RGB(255, 0, 0)
With ActiveSheet.Range("$A$1:$U$500")
Set r = .Find(What:="", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
MatchByte:=False, SearchFormat:=True)
r.Select
While Not r Is Nothing
r.EntireRow.Delete
Set r = .Find(What:="", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
MatchByte:=False, SearchFormat:=True)
Wend
End With
For s = 11 To 17
Cells(2, s - 7) = ExecuteExcel4Macro("'C:\temp\Book2.xlsx]Sheet1'!R" & i & "C" & s & "")
Next s
For s = 11 To 17
Cells(1, s - 7) = ExecuteExcel4Macro("'C:\temp\Book2.xlsx]Sheet1'!R" & i - 1 & "C" & s & "")
Next s
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows8 ＞
コードはよく読んでいないのですが、一般論として。
Findメソッド、これは、シート上の検索操作そのものなんですが、シート上でも検索対象がなければ 【ありません】というメッセージがでますね。
コード実行でも同じことで、見つかれば r には、そのセルの Rangeオブジェクトが入りますが、 見つからなかった場合は、'Nothing' が返されます。
で、r が Nothing ですから r.Select とやろうとすると、エクセルが、どこを選択していいのかわからず こんな領域はないぞ！！！ と叱るわけです。
そもそも、このコードでは r.Select って必要ないでしょ？ どこでも、Selection を参照していませんので。
ところで、インデントを全くつけない、このコード、自分でも見づらくないですか？
（β） 2016/03/05(土) 04:48
テーマとは関係ありませんが気になったので。
Book2.xlsx の最初のシートのシート名は "Sheet1" になっているんだと思われますが appExcel.Worksheets(1) を参照して、その使用領域の最大行番号を取得していますね。 で、後半の値転記は "Sheet1" という名前を特定して参照しています。
もし、最初のシートが "Sheet1" ではなかったら、おかしなことになります。
また、最初のシートは "Sheet1" だから大丈夫だということなら、appExcel.Worksheets(1) も appExcel.Worksheets("Sheet1") と記述するほうがわかりやすいですね。
（というか、そのように記述すれば、万が一シートの順番がいれかわって保存されていたとしても不具合は回避できますから）
また、ちゃんと認識して、使っておられるのでしょうが、Set appExcel = GetObject("C:\temp\Book2.xlsx") これは、非表示ブックにはなりますが
実際にエクセル区画で開かれています。（普通のコードでは Workbooks.Open を実行するところでしょうし、それと表示・非表示をのぞけばかわりありません）
何を言いたいかというと、この Book2.xlsxの"Sheet1"からマクロブックのアクティブシートに値を取り込むためにわざわざ【不自由な】ExecuteExcel4Macro を使う必要は 全くなく、【普通の】転記コードが使えます。しかも、転記のためにループさせる必要はさらさらなく、コピペであっても、転記先.Value = 転記元.Value であってもいいですが 1行で転記ができますよ。
（β） 2016/03/05(土) 08:50
たぶん、こういうことなんじゃないかと推測で。
Sub Test()
Dim appExcel As Object
Dim i As Long
Dim r As Range
Set appExcel = GetObject("C:\temp\Book2.xlsx")
i = appExcel.Sheets("Sheet1").UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
Application.FindFormat.Interior.Color = vbRed
With ActiveSheet.Range("$A$1:$U$500")
Set r = .Find(What:="", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
MatchByte:=False, SearchFormat:=True)
While Not r Is Nothing
r.EntireRow.Delete
Set r = .Find(What:="", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
MatchByte:=False, SearchFormat:=True)
Wend
End With
Range("D2:J2").Value = appExcel.Sheets("Sheet1").Range("K" & i).Resize(, 7).Value
Range("D1:J1").Value = appExcel.Sheets("Sheet1").Range("K" & i - 1).Resize(, 7).Value
appExcel.Close False 'あとあと悪さをしないよう念のため
Set appExcel = Nothing '同上
End Sub
（β） 2016/03/05(土) 13:27
↑ あっ！ コードでは色付きセルの行削除はアクティブブックのシートに対する処理だったので それに合わせたコード案をアップしましたが、質問文では、
>>Book2の、同じ色がランダムに付いた行を消してから最終行の2行の一部をコピーして
とありますから、行削除すべきは Set appExcel = GetObject("C:\temp\Book2.xlsx") で持ってきた Book2だったんですね？
不思議だなぁと思うのは、もし、r.Select によるエラーが発生しないようなシートだった場合処理はされるわけですけど その時、おかしいなとは思われなかったのですか？
それとも、そちらでは、Book2の色付き行が削除されているのですか？
（β） 2016/03/05(土) 15:02
↑でコメントしたような要件だったとしたら。
Sub Test2()
Dim appExcel As Object
Dim i As Long
Dim r As Range
Dim shF As Worksheet
Dim shT As Worksheet
Set appExcel = GetObject("C:\temp\Book2.xlsx")
Set shF = appExcel.Sheets("Sheet1")
Set shT = Workbooks("Book1.xlsx").Sheets("Sheet1") '★ ここは実際のものに
Application.FindFormat.Interior.Color = vbRed
With shF.Range("$A$1:$U$500")
Set r = .Find(What:="", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
MatchByte:=False, SearchFormat:=True)
While Not r Is Nothing
r.EntireRow.Delete
Set r = .Find(What:="", After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
MatchByte:=False, SearchFormat:=True)
Wend
End With
i = shF.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
shT.Range("D2:J2").Value = shF.Range("K" & i).Resize(, 7).Value
shT.Range("D1:J1").Value = shF.Range("K" & i - 1).Resize(, 7).Value
appExcel.Close False 'あとあと悪さをしないよう念のため
Set appExcel = Nothing '同上
End Sub
（β） 2016/03/05(土) 15:14
Sub test()
Dim ws As Worksheet
Dim wb As Workbook
Dim i As Long
Dim c As Range, r As Range
Dim n As Long
Set ws = ActiveSheet '★転記先シート
Application.ScreenUpdating = False
Set wb = Workbooks.Open("C:\temp\Book2.xlsx")
With wb.Sheets("Sheet1").Range("A1:U" & Range("A" & Rows.Count).End(xlUp).Row)
Application.FindFormat.Clear
Application.FindFormat.Interior.Color = vbRed
For i = .Rows.Count To 1 Step -1
Set c = .Rows(i).Find(What:="", SearchFormat:=True)
If c Is Nothing Then
n = n + 1
If n = 1 Then
Set r = .Rows(i)
Else
Set r = Union(r, .Rows(i))
End If
If n = 2 Then Exit For
End If
Next
End With
If Not r Is Nothing Then
r.Columns("K:Q").Copy
ws.Range("D1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Application.FindFormat.Clear
wb.Close False
End Sub
（マナ） 2016/03/05(土) 19:38
失礼します。
To マナさん
おそらく・・・・・まず、Book2シートで赤色セル行があれば削除し、 その上で（削除された後の）シートイメージを取り込むのではと・・・
（β） 2016/03/05(土) 20:26
（マナ） 2016/03/05(土) 20:43
後出しですが、Book2のSheet1のセルには○、×、-などの選択肢があり、
一覧の一番下にその項目ごとの合計があって、
さらに一覧には該当しないものに色がつけてあったので、
参考のURLを元にした結果、r.Selectの問題にぶつかってしまったわけです。
もちろん、r.Selectでエラーになるため、色付きの行は削除されません。
また、該当しない行を削除すると、合計行の行番号が変わってしまうため、
「最後の行」のマクロを使用していました。
今まで、必要だと思ったコードをネットで探してコピペしていたので、
訳も分からずマクロを組んでいました。
これを機会に勉強します。
（パン） 2016/03/06(日) 13:51
先の Application.FindFormat.Interior.Color = vbRed、
この部分の色が実際は RGB(89,89,89)なので、
Application.FindFormat.Interior.Color = RGB(89,89,89)
にしましたが、会社の方ではだめでした。-5855577 でもだめでした。
次に元々のシートに設定されている色は、セルの書式設定の塗りつぶしの、
左から2列目の上から3番目を選択（色はRGB(89,89,89)）するのを、
マクロの記録で行った、
Selection.Interior.ThemeColor = xlThemeColorLight1
のを記述してみましたが、会社の方ではだめでした。
ですが、会社の方で成功したのは、Book2の方の、セルの書式設定の塗りつぶしのパレットを選択して、
「その他の色」をクリック→[OK]でRGB(89,89,89)を選択しつつパレットでは選択されていない状態にしたら、
Application.FindFormat.Interior.Color = RGB(89,89,89)で動作しました。
ただ、パレットの色を選択してから「その他の色」→[OK]をするのは
ほかのユーザーさんが行うには面倒です。
ちなみに共有の解除も行いましたが、変わりませんでした。
If ActiveWorkbook.MultiUserEditing Then
ActiveWorkbook.ExclusiveAccess
Application.ActiveProtectedViewWindow.Edit
End If
会社の方で RGB(89,89,89)の行を削除するにはどうしたらいいでしょうか。
分かりづらい説明で申し訳ありませんが、どうかよろしくお願いいたします。
（パン） 2016/03/15(火) 22:26
>>会社の方で RGB(89,89,89)の行を削除するにはどうしたらいいでしょうか。
この意味がよくわからないのですが？ コードを削除？ 色のついたシート上の行を削除？ いずれにしても、削除が必要なら削除すればいいのでは？
同じ色をつけていれば、色番号指定で、ＰＣに限らず、どのＰＣでも、問題はないと思います。 ただ、コードでは 赤 だという処理をしても 赤 が、人それぞれ、いろんな 赤がありますのでね。
ところで、RGB(89,89,89) は 色番号 5855577 ですよね。（-5855577 とは違う色） で、いずれの色も、赤とは、ほど遠い色調ですが？
いずれにしても、コードが期待する色を正しく使ってもらうというのは、なかなか難しいのかもしれません。 色つけマクロを準備して、それにマクロショートカット（たとえば a ）を割り当てておき、セル選択した後 パレットから選ばずに、 Ctrl/a とやってもらうのがいいかもしれませんね。
Sub Test()
Selection.Interior.Color = vbRed
End Sub
（β） 2016/03/16(水) 06:37
別案です。
もし、$A$1:$U$500 の範囲内のセルの色、これが操作者によってまちまちなので 判定が困難だということであれば、その範囲内に、別の目的の色はセットされていない、 逆にいえば、どんな色であれ、色付きのセルがあれば、その行は削除するということで無理がないとすれば Findでの書式検索ではなく 1～500 行のループ処理で、その行の A列:U列 の セルの ColorIndex を取得し 取得結果が Null あるいは xlNone以外の値なら 削除対象の行だという方式でもいけるのですが。
以下コード。書いただけで動かしていないので不具合あれば御容赦。
Sub Test3()
Dim appExcel As Object
Dim i As Long
Dim r As Range
Dim shF As Worksheet
Dim shT As Worksheet
Dim chk As Boolean
Dim z As Variant
Dim dlt As Range
Set appExcel = GetObject("C:\temp\Book2.xlsx")
Set shF = appExcel.Sheets("Sheet1")
Set shT = Workbooks("Book1.xlsx").Sheets("Sheet1") '★ ここは実際のものに
With shF.Range("$A$1:$U$500")
For Each r In .Rows
chk = False
z = r.Interior.ColorIndex
If IsNull(z) Then
chk = True
ElseIf z <> xlNone Then
chk = True
End If
If chk Then
If dlt Is Nothing Then
Set dlt = r.EntireRow
Else
Set dlt = Union(dlt, r.EntireRow)
End If
End If
Next
End With
If Not dlt Is Nothing Then dlt.Delete
i = shF.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
shT.Range("D2:J2").Value = shF.Range("K" & i).Resize(, 7).Value
shT.Range("D1:J1").Value = shF.Range("K" & i - 1).Resize(, 7).Value
appExcel.Close False 'あとあと悪さをしないよう念のため
Set appExcel = Nothing '同上
End Sub
（β） 2016/03/16(水) 07:01
会社にある Excel2010 で何台か試しましたが、なぜか IndexColor 以外の色は受け付けないようなので、
「2016/03/05(土) 15:14」の方法で RGB(89,89,89) の指定では、RGB(89,89,89) で塗られた
行のマクロでの削除はできませんでした。
（自宅のExcel2010とExcel2013では成功してました。）
ちなみに色の指定は以下の3通りで試しました。
いづれも自宅では成功し、会社では失敗したものです。
Application.FindFormat.Interior.Color = RGB(89, 89, 89)
Application.FindFormat.Interior.ThemeColor = xlThemeColorLight1
Selection.Interior.ThemeColor = xlThemeColorLight1
「2016/03/16(水) 07:01」のは10数枚のBookを処理するのに続けて行った際、2回目の
「Set dlt = Union(dlt, r.EntireRow)で「'Union'メソッドは失敗しました」で止まってしまいました。
また黄色等、RGB(89,89,89)以外の色も削除されてしまうので、申し訳ありませんが使うことができません。
結局、会社での動作確認は不明ですが、マクロの記録で処理することにしてみます。
Sub Test4()
Dim Wb As Workbook
Dim i As Long
Dim shF As Worksheet
Dim shT As Worksheet
Set Wb = Workbooks.Open("C:\temp\Book2.xlsx")
Set shF = Wb.Sheets("Sheet1")
Windows("Book2.xlsx").Activate
Sheets("Sheet1").Select
ActiveSheet.Range("$A$12:$S$500").AutoFilter Field:=3, Criteria1:=RGB(89, 89 _
, 89), Operator:=xlFilterCellColor
Rows("12:500").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$12:$S$500").AutoFilter Field:=3
Set shT = Workbooks("Book1.xlsm").Sheets("Sheet1")
i = shF.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
shT.Range("D2:J2").Value = shF.Range("K" & i).Resize(, 7).Value
shT.Range("D1:J1").Value = shF.Range("K" & i - 1).Resize(, 7).Value
Workbooks("Book2.xlsx").Close SaveChanges:=False
End Sub
ですが、ExecuteExcel4Macro にこだわったせいで GetObject にしたりしていましたが、
Workbooks.Open にしたら軽くなったり、shT.Range のところも自分では書けなかったので、
とても助かりました。
連休明けの会社での動作確認が不安ですが、改めて結果報告いたします。m(_ _)m
（パン） 2016/03/19(土) 11:01
>>会社にある Excel2010 で何台か試しましたが、なぜか IndexColor 以外の色は受け付けないようなので
2010 で、うけいれられなかったのですか？
2003までなら、色はカラーインデックスで設定されている５６色しかなく、いくら色番号を指定しても カラーインデックスに登録のない色番号の場合、近い色に置き換わってしまうので RGB(89,89,89) で色塗りしても RGB(89,89,89) にはなりませんけど、2010なら、絶対にそういうことはないはずですが？
（β） 2016/03/19(土) 20:26
いや、そんなことではなく、実際に不具合が発生したPCがあるわけですよね。 そのPCでエクセルを立ち上げて処理していますよね。 その立ち上がったエクセルのバージョンが2010なのかどうかを確かめていただきたいのですが。
（β） 2016/03/29(火) 22:55
ちなみに、2016/03/15(火) 22:26発言の「セルの書式設定の塗りつぶしのパレットを選択して、
「その他の色」をクリック→[OK]でRGB(89,89,89)を選択しつつパレットでは選択されていない状態にしたら、
Application.FindFormat.Interior.Color = RGB(89,89,89)で動作しました。 」
のパレットは、「セルの書式設定」→「塗りつぶし」の左から2列目の、線を跨いだ上から3番目です。
これがRGB(89,89,89)になります。
（パン） 2016/03/31(木) 00:42
絶対に、そのＰＣは2003 ではないということ（2007以降ではないということ） 了解しました。
基本に戻って、新規ブックの標準モジュールに以下のコードを貼り付けで、そのだめな2台で、そのパレットから色を選び 色付けしたセルを選択して Test を実行すると、どんな値が表示されますか。（上段、色番号、下段、RGBの形式）
これが 89,89,89 でないとすれば、カラーパレットの別の場所を選んでいるか、 あるいは、そのＰＣのパレットのその場所にセットされた色が別物ということになります。
ちなみに、当方のカラーパレットで 89,89,89 になるのは 以下の ■ の場所のボタンです。
色なし
□□□□・・・・・
====================
□□□□・・・・・
□■□□・・・・・
□□□□・・・・・
Type RGBSET
r As Long
g As Long
b As Long
End Type
Sub test()
Dim w As RGBSET
w = divRGB(Selection.Interior.Color)
MsgBox Selection.Interior.Color & vbLf & "RGB(" & w.r & "," & w.g & "," & w.b & ")"
End Sub
Function divRGB(rgbVal As Long) As RGBSET
divRGB.b = rgbVal \ 256 ^ 2
divRGB.g = (rgbVal - divRGB.b * 256 ^ 2) \ 256
divRGB.r = rgbVal - divRGB.b * 256 ^ 2 - divRGB.g * 256
End Function
（β） 2016/03/31(木) 07:17
ちょっとここで残念なお知らせです。
3月末で契約更新が切れてしまい、これ以上の検証はできなくなりました。
βさんには最後まで付き合ってくださり、何度お礼を言っても足りないくらいです。
本当にありがとうございました。
'自宅の2010と2013では、βさんのマクロ（ 2016/03/05(土) 15:14）は正常に動作しますので、
'検証にはなりませんよね。
（パン） 2016/04/04(月) 22:52
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.