Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

187 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【78713】Re:ペーストのVBA

初心 - 16/12/21(水) 14:29 -


	引用なし

	パスワード

▼β さん　またまたありがとうございます。
>１．コピー後、ペースト前に 10秒間 Wait している理由は？
→コピーとペーストまでの操作時間が影響している可能性があるのかもという
記述を調べている時にみつけたので、追加してみました。ただこれが必要なのか
現状ではわからないんです。ごめんなさい

>
>２．Range("F3:F200").Select
>　　Selection.ClearContents
>
>　　コピペ後、抽出判定領域の F列をクリアしている意味は？
次に使う人が使いやすい様にクリアした方がいいのかなとおもった次第です。　
ここのシートには、商品データがあり
フィルタを使って必要なものを表示→請求書へ転記というものを作りたく。

>
>３．ActiveSheet.Range("$A$2:$F$134").AutoFilter Field:=6
>　　ActiveSheet.Range("$A$2:$F$200").AutoFilter Field:=1
>　　
>　　処理後、フィルタリング状態を解除し、全データ表示にしたいのでしょうけど
→はいそのとおりなんです。

>　　１）アップされたコードには見当たりませんが A列でもフィルタリングしているのですか？
→はい。A列にはカテゴリーとして一覧があるので　カテゴリをフィルタ→F列に商品があるので必要商品を1と入力して選んだものをコピーする様にしたかったんです。
>　　２）F列とA列の領域、一方は134行目まで、一方は200行目と、違っているのはなぜですか？
→申し訳ありません、データの数が増えてもいいように、134→200にしたものを
片方変更もれです。

・ツリー全体表示


	【78712】Re:ペーストのVBA

初心 - 16/12/21(水) 14:22 -


	引用なし

	パスワード

お返事ありがとうございます。

エラー内容は、この操作には、同じサイズの結合せるが必要ですと
出るんですが、結合してるセルもないので･･･サイズなのかなと思ったりしたんですが違うみたいで･･･

▼β さん：
>▼初心さん：
>
>コードそのものは、改善できるところ（もしくは、修正しなければいけないところ）がたくさんありますが、
>とりあえずwsDataシートに、正しいタイトル行があり、
>かつ、抽出対象データがあればエラーにはなりませんよ。
>
>抽出対象データがなければ
>
>Selection.SpecialCells(xlCellTypeVisible).Select
>
>でエラーになりますが。
>
>1004エラーとともに、なぜ1004エラーになったのかのメッセージが出ているはずですが
>どういったメッセージでしたか？
>
>wsInvoiceシートにシート保護がかかっているということはないですか？

・ツリー全体表示


	【78711】Re:ペーストのVBA

β - 16/12/21(水) 13:25 -


	引用なし

	パスワード

▼初心さん：

ついでに質問します。

１．コピー後、ペースト前に 10秒間 Wait している理由は？

２．Range("F3:F200").Select
　　Selection.ClearContents

　　コピペ後、抽出判定領域の F列をクリアしている意味は？

３．ActiveSheet.Range("$A$2:$F$134").AutoFilter Field:=6
　　ActiveSheet.Range("$A$2:$F$200").AutoFilter Field:=1
　　
　　処理後、フィルタリング状態を解除し、全データ表示にしたいのでしょうけど

　　１）アップされたコードには見当たりませんが A列でもフィルタリングしているのですか？
　　２）F列とA列の領域、一方は134行目まで、一方は200行目と、違っているのはなぜですか？

・ツリー全体表示


	【78710】Re:ペーストのVBA

β - 16/12/21(水) 13:11 -


	引用なし

	パスワード

▼初心さん：

コードそのものは、改善できるところ（もしくは、修正しなければいけないところ）がたくさんありますが、
とりあえずwsDataシートに、正しいタイトル行があり、
かつ、抽出対象データがあればエラーにはなりませんよ。

抽出対象データがなければ

Selection.SpecialCells(xlCellTypeVisible).Select

でエラーになりますが。

1004エラーとともに、なぜ1004エラーになったのかのメッセージが出ているはずですが
どういったメッセージでしたか？

wsInvoiceシートにシート保護がかかっているということはないですか？

・ツリー全体表示


	【78709】Re:セルに入力されたら印刷

β - 16/12/21(水) 13:01 -


	引用なし

	パスワード

▼北風さん：

１つのモジュールに同じ名前のプロシジャを書くことはできません。
現在のものと、アップしたものが共存できるように組み立てることが必要です。
現在のものを、そのまま、コピペでアップしてください。

・ツリー全体表示


	【78708】Re:セルに入力されたら印刷

北風 - 16/12/21(水) 12:25 -


	引用なし

	パスワード

▼β さん：
>▼北風さん：
>>Q31セルに数字が入力されたら印刷を実行する方法を教えてくれますか
>
>Ｑ３１に数字が入るたびに印刷されるということが、いいのかわるいのか？
>
>そのシートのシートタブを右クリックしてコードの表示を選びます。
>でてきたところに以下を貼り付け、画面左上のＸボタンをクリックして
>シートに戻ります。
>
>これで、Q31に何か数字を入れてみてください。
>
>Private Sub Worksheet_Change(ByVal Target As Range)
>　　If Intersect(Target, Range("Q31")) Is Nothing Then Exit Sub
>　　If IsNumeric(Range("Q31").Value) Then
>　　　　Me.PrintOut
>　　End If
>End Sub

Private Sub Worksheet_Change(ByVal Target As Range)を２つ利用しているためエラーになります回避方法ありますか。

・ツリー全体表示


	【78707】Re:ペーストのVBA

初心 - 16/12/21(水) 11:21 -


	引用なし

	パスワード

▼初心さん：
>初めて投稿させていただきます。
>シート１で、ﾌｨﾙﾀｰし表示されているのをシートにの任意CELL(A21）へ
>値のみコピーしたいのですが･･･。どうしてもﾍﾟｰｽﾄの部分でエラー1004が
>でます。
>
>wsData.Range("$A$2:$H$200").AutoFilter Field:=6, Criteria1:="1"
>　　Selection.SpecialCells(xlCellTypeVisible).Select
>　　Selection.Copy
>　　Application.Wait Now + TimeValue("0:00:10")
>　　wsInvoice.Select
>　　Range("A21").Select
>ここの部分です↓
>　　Selection.PasteSpecial Paste:=xlPasteValues
>　　Application.CutCopyMode = False
>　　wsData.Select
>　　Range("F3:F200").Select
>　　Selection.ClearContents
>　　ActiveSheet.Range("$A$2:$F$134").AutoFilter Field:=6
>　　ActiveSheet.Range("$A$2:$F$200").AutoFilter Field:=1
>　　wsInvoice.Select
>　　Range("F21").Select
>End Sub
>
>2日ほどいろいろ試しているのですが、そこのﾍﾟｰｽﾄを抜くとエラーにならないので
>ﾍﾟｰｽﾄ部分

申し訳ありません・・・途中で送信してしまった用です･･･
マクロの記録を使って色々試してはいるものの、どうしてもﾍﾟｰｽﾄの部分がエラーになるので、ご教示いただきたく　何卒よろしくお願いいたします。

・ツリー全体表示


	【78706】ペーストのVBA

初心 - 16/12/21(水) 11:06 -


	引用なし

	パスワード

初めて投稿させていただきます。
シート１で、ﾌｨﾙﾀｰし表示されているのをシートにの任意CELL(A21）へ
値のみコピーしたいのですが･･･。どうしてもﾍﾟｰｽﾄの部分でエラー1004が
でます。

wsData.Range("$A$2:$H$200").AutoFilter Field:=6, Criteria1:="1"
　　Selection.SpecialCells(xlCellTypeVisible).Select
　　Selection.Copy
　　Application.Wait Now + TimeValue("0:00:10")
　　wsInvoice.Select
　　Range("A21").Select
ここの部分です↓
　　Selection.PasteSpecial Paste:=xlPasteValues
　　Application.CutCopyMode = False
　　wsData.Select
　　Range("F3:F200").Select
　　Selection.ClearContents
　　ActiveSheet.Range("$A$2:$F$134").AutoFilter Field:=6
　　ActiveSheet.Range("$A$2:$F$200").AutoFilter Field:=1
　　wsInvoice.Select
　　Range("F21").Select
End Sub

2日ほどいろいろ試しているのですが、そこのﾍﾟｰｽﾄを抜くとエラーにならないので
ﾍﾟｰｽﾄ部分

・ツリー全体表示


	【78705】Re:セルに入力されたら印刷

β - 16/12/21(水) 10:30 -


	引用なし

	パスワード

▼北風さん：
>Q31セルに数字が入力されたら印刷を実行する方法を教えてくれますか

Ｑ３１に数字が入るたびに印刷されるということが、いいのかわるいのか？

そのシートのシートタブを右クリックしてコードの表示を選びます。
でてきたところに以下を貼り付け、画面左上のＸボタンをクリックして
シートに戻ります。

これで、Q31に何か数字を入れてみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Intersect(Target, Range("Q31")) Is Nothing Then Exit Sub
　　If IsNumeric(Range("Q31").Value) Then
　　　　Me.PrintOut
　　End If
End Sub

・ツリー全体表示


	【78704】セルに入力されたら印刷

北風 - 16/12/21(水) 8:59 -


	引用なし

	パスワード

Q31セルに数字が入力されたら印刷を実行する方法を教えてくれますか

・ツリー全体表示


	【78703】Re:よろしくお願いいたします。

斎藤 - 16/12/19(月) 23:26 -


	引用なし

	パスワード

こんばんは。
遅くなりまして、申し訳ありません。

2013で確認したところ、sample3が問題なく動作しました。
こちらを使用させていただきます。
sheet名については、手間ではないためこのまま行かせていただきます。
最後までお付き合い下さり、感謝しております。
この度は本当にお世話になりました。

・ツリー全体表示


	【78702】追記

acs - 16/12/19(月) 15:49 -


	引用なし

	パスワード

Sub Sample1()
　　 Dim pic As Picture
　　 Dim f As Variant
　　 Dim Target As Range
　
　　 'A1の画像を削除
　　 For Each pic In ActiveSheet.Pictures
　　　　 If pic.TopLeftCell.Address = "$A$2" Then pic.Delete
　　 Next
　
　　 Set Target = Range("A2:A10")
　
　　 f = Application.GetOpenFilename _
　　　　　　("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
　　 If f <> False Then
　　　　 With ActiveSheet.Shapes.AddPicture(Filename:=f, LinkToFile:=False, _
　　　　　　 SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
　　　　　　 Width:=-1, Height:=-1)　　　'-1 元の大きさで貼り付け
　　　　　　 '===============タテヨコの縮尺を保持して拡大または縮小
　　　　　　 .LockAspectRatio = True　　 '縦横比率の維持（念のため）
　　　　　　 .Height = Target.Height
　　　　 End With
　　 End If

End Sub

Sub Sample2()
　　 Dim pic As Picture
　　 Dim f As Variant
　　 Dim Target As Range
　
　　 'A1の画像を削除
　　 For Each pic In ActiveSheet.Pictures
　　　　 If pic.TopLeftCell.Address = "$A$12" Then pic.Delete
　　 Next
　
　　 Set Target = Range("A12:A20")
　
　　 f = Application.GetOpenFilename _
　　　　　　("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
　　 If f <> False Then
　　　　 With ActiveSheet.Shapes.AddPicture(Filename:=f, LinkToFile:=False, _
　　　　　　 SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
　　　　　　 Width:=-1, Height:=-1)　　　'-1 元の大きさで貼り付け
　　　　　　 '===============タテヨコの縮尺を保持して拡大または縮小
　　　　　　 .LockAspectRatio = True　　 '縦横比率の維持（念のため）
　　　　　　 .Height = Target.Height
　　　　 End With
　　 End If

End Sub

というＶＢＡを使っているのですが、Excel2007で使用すると、A2に貼られたPICは
よいのですが、A12に貼られたPICはA12のセル左隅から少し下に、さらにA22では
ズレがおおきくなり、最終的にA301ではとんでもなくズレが生じてしまいます。

環境は以下の通りです
　
　PC:FUJITSU D751/C　　　win7 Excel2010 14.0.7177.5000(32bit)
　Printer:Canon LBP-3600
　

　PC:FUJITSU CE227D　　　win10 Excel2010 14.0.4760.1000(32bit)
　Printer:Canon LBP-8620

　余白は共に左2.5、上・下・右1.0

・ツリー全体表示


	【78701】違うPCだとセルや印刷範囲が変わる

acs - 16/12/19(月) 14:23 -


	引用なし

	パスワード

VBAのせいなのか、Verのせいなのか
Excel2010 14.0.7177.5000(32bit)
で作成したものを
Excel2010 14.0.4760.1000(32bit)
で開くとセルの高さやVBAで作成した印刷範囲が変わっていしまうのは
なぜでしょうか？

具体的には、

1.セルの高さが38で作成しものが48に変わる
　同様に5→6、45→56
2.印刷範囲が1頁分A1～D31、2頁分A1～D62とVBAで作っているので1.の理由により
　1頁目が2頁目の途中まで、2頁目が2頁目の途中から4頁目までと意図しない
　感じになってしまいます。
　Excel2010 14.0.4760.1000(32bit)でセルの高さを6→5、48→38、56→45に
　戻してもうまくいきません

　プリンターのせいなのでしょうか？
　それともVBA？
　ハタマタVerのせいなのでしょうか？

　もしVerのせいなのであれば、どうしたらよいのでしょうか？
　2007、2013、2016と違っていても、書式の統一は出来るのでしょうか？

　環境は以下の通りです
　
　PC:FUJITSU D751/C　　　Excel2010 14.0.7177.5000(32bit)
　Printer:Canon LBP-3600
　

　PC:FUJITSU CE227D　　　Excel2010 14.0.4760.1000(32bit)
　Printer:Canon LBP-8620

　余白は共に左2.5、上・下・右1.0

・ツリー全体表示


	【78700】Re:よろしくお願いいたします。

β - 16/12/18(日) 20:20 -


	引用なし

	パスワード

▼斉藤さん：

迷惑かけました。
改訂版です。お試しください。

Transpose 要素数の制限は認識していましたが、要素内の文字の桁数制限は
はじめて認識しました。

勉強になりました。

Sub Sample()
　　Dim c As Range
　　Dim dic1 As Object
　　Dim dic2 As Object
　　Dim w As Variant
　　Dim v As Variant
　　Dim x As Long
　　
　　Set dic1 = CreateObject("Scripting.Dictionary")
　　Set dic2 = CreateObject("Scripting.Dictionary")
　
　　With Sheets("Sheet1")
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　If Not dic1.exists(c.Value) Then
　　　　　　　　dic1(c.Value) = c.EntireRow.Range("A1:P1").Value
　　　　　　　　dic2(c.Value) = c.EntireRow.Range("Q1").Value
　　　　　　Else
　　　　　　　　dic2(c.Value) = dic2(c.Value) & "," & c.EntireRow.Range("Q1").Value
　　　　　　End If
　　　　Next
　　End With
　
　　With Sheets("Sheet2")
　　　　.Cells.ClearContents
　　　　.Range("A1:P1").Resize(dic1.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic1.items))
　　　　w = dic2.items
　　　　ReDim v(0 To UBound(w, 1), 1 To 1)
　　　　For x = 0 To UBound(w, 1)
　　　　　　v(x, 1) = w(x)
　　　　Next
　　　　.Range("Q1").Resize(dic2.Count).Value = v
　　　　.Select
　　End With
　
End Sub

Sub Sample2()
　　Dim c As Range
　　Dim dic As Object
　　Dim v As Variant
　　Dim w As Variant
　　Dim x As Long
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　
　　With Sheets("Sheet1")
　　　　v = .Range("A1").CurrentRegion.Columns("A:P").Value
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　If Not dic.exists(c.Value) Then
　　　　　　　　dic(c.Value) = c.EntireRow.Range("Q1").Value
　　　　　　Else
　　　　　　　　dic(c.Value) = dic(c.Value) & "," & c.EntireRow.Range("Q1").Value
　　　　　　End If
　　　　Next
　　End With
　
　　With Sheets("Sheet2")
　　　　.Cells.ClearContents
　　　　.Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
　　　　.Columns("A:P").RemoveDuplicates Columns:=1, Header:=xlYes
　　　　w = dic.items
　　　　ReDim v(0 To UBound(w, 1), 1 To 1)
　　　　For x = 0 To UBound(w, 1)
　　　　　　v(x, 1) = w(x)
　　　　Next
　　　　.Range("Q1").Resize(dic.Count).Value = v
　　　　.Select
　　End With
End Sub

Sub Sample3()
　　Dim c As Range
　　Dim dic As Object
　　Dim w As Variant
　　Dim v As Variant
　　Dim x As Long
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　
　　With Sheets("Sheet1")
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　If Not dic.exists(c.Value) Then
　　　　　　　　dic(c.Value) = c.EntireRow.Range("Q1").Value
　　　　　　Else
　　　　　　　　dic(c.Value) = dic(c.Value) & "," & c.EntireRow.Range("Q1").Value
　　　　　　End If
　　　　Next
　　End With
　
　　With Sheets("Sheet2")
　　　　.Cells.ClearContents
　　　　Sheets("Sheet1").Columns("A:P").AdvancedFilter Action:=xlFilterCopy, _
　　　　　　CopyToRange:=.Range("A1"), Unique:=True
　　　　w = dic.items
　　　　ReDim v(0 To UBound(w, 1), 1 To 1)
　　　　For x = 0 To UBound(w, 1)
　　　　　　v(x, 1) = w(x)
　　　　Next
　　　　.Range("Q1").Resize(dic.Count).Value = v
　　　　.Select
　　End With
　　
End Sub

・ツリー全体表示


	【78699】Re:よろしくお願いいたします。

β - 16/12/18(日) 20:12 -


	引用なし

	パスワード

▼斉藤さん：

原因がわかったようです。
今までのテストパターンでは Q列の文字列連結結果の桁数が小さかったのですが
これを、元データの桁数を長くし、かつ、A列が同じものをたくさん作って実行。
結果、Q列の文字数が長くなって、これは、そのままセットすれば問題がないのですが
Transposeを掛けたとき、その制限に引っかかったようです。

Sample1,2,3 とも、そのエラー対応をした上で、後ほどアップします。

・ツリー全体表示


	【78698】Re:よろしくお願いいたします。

β - 16/12/18(日) 20:03 -


	引用なし

	パスワード

▼斉藤さん：

こちらで、今、パターンを変えて実行すると、型が一致しないというエラーが再現しました。
偉そうにいっていましたが、どこかにバグがあるわけですね。

調べま～す。（ごめんなさい）

・ツリー全体表示


	【78697】Re:よろしくお願いいたします。

斉藤

- 16/12/18(日) 20:00 -


	引用なし

	パスワード

▼β さん：

本当に何度も申し訳ありません。
今回はEXCEL2007を使用させて頂きました。

>　ですので、会社の 2013 による検証、よろしくお願いしますね

承知致しました。
砂時計となり、処理を繰り返しているようです。

ただ、まずは2013で動作検証してからで、報告させていただきますので、それからで結構です。

引き続きよろしくお願い致します。

・ツリー全体表示


	【78696】Re:よろしくお願いいたします。

β - 16/12/18(日) 19:43 -


	引用なし

	パスワード

▼斎藤さん：

>やむを得ず先に2007で確認いたしました。

2007があったということですか？
で、2007でもＮＧだったということですか？

2002 の間違いでしょうか。

もちろん、こちらでは、いくつかのパターンを想定して、動かしていますが
どのコードも、それぞれのパターンに対して正常に処理されています。

ですので、会社の 2013 による検証、よろしくお願いしますね。

>また、マシンパワーを相当食うようで2分程度処理に時間が掛っており、sample2は固まってしまいました。

たかだか8000件であれば、瞬時に終了するはずです。
何か、別の原因があると思いますねぇ。

>私のお願いしたやり方では時間が掛るのかなと思いますので、生意気を言って申し訳ありませんが…以下のような形にできますでしょうか？

う～ん・・・
どうしても　ということなら、コードを書きますけど、会社のxl2013で検証した後ということでは
遅すぎる、もっと早くコードがほしいということですか？

・ツリー全体表示


	【78695】Re:よろしくお願いいたします。

斎藤

- 16/12/18(日) 17:13 -


	引用なし

	パスワード

▼β さん：

お世話になります。
本日近所の環境を探したところ、EXCEL2007以上が見つからず、やむを得ず先に2007で確認いたしました。
結果から申し上げますと、頂いたsample1と3は「型が一致しません」というエラー表示がされ、Q列は表示されませんでした。
また、マシンパワーを相当食うようで2分程度処理に時間が掛っており、sample2は固まってしまいました。

元シート名をリネームし　"Sheet1"、転記シート名を追加し "Sheet2" して実施いたしました。

私のお願いしたやり方では時間が掛るのかなと思いますので、生意気を言って申し訳ありませんが…以下のような形にできますでしょうか？

1. 作業シートSheet2を作成→A列を参照して若番から順にソートしていただき、転記。A列でソートされた形でA～Qまでが並びます。

2. 作業シートSheet2を、重複のある行をQ列のみ処理をしていくのですが、重複行1行目のQ以降にQ,重複行2行目は重複行1行目のR,重複行3行目は重複行1行目のS,…T,U,V…などという形で転記します。

3. R以降のセルがある場合にはQ列に結合（Q列にデータの存在しないものもあります。）→A列の重複行を削除という流れになるとシンプルになるのではないかな？と思っています。（作業シートで処理を進めて頂いても構いませんし、resultsシートに結果表示させて頂いても構いません。）

もちろん明日以降に2013にてsample1～3を試させて頂きますが、できますならばご検討下さい。

・ツリー全体表示


	【78694】Re:よろしくお願いいたします。

β - 16/12/17(土) 13:15 -


	引用なし

	パスワード

▼斉藤さん：

アップしたコード、いずれもサンプルとして、
元シート名が　"Sheet1"、転記シート名が "Sheet2" となっています。

なので、それぞれのシート名を実際のものに変更すればＯＫです。

転記シートですが、マクロで動的に作りだすということはもちろんできますが
とりあえずは最初から用意しておいてください。

存在しない場合は動的に作りだしたいということであれば、現在のコードが
ちゃんとxl2013で動くことを確認してから追加しますので。

なお、Sample3 ですけど、A～P のすべての列の値で重複削除をしています。
A列が同じなら B～P も同じということなら問題ないですが、万が一、そうではないﾃﾞｰﾀがあれば
結果はおかしくなりますので。

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

187 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free