Excel VBA質問箱 IV

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

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


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

188 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【78693】Re:ランダムに提示

戸梶 - 16/12/17(土) 12:13 -


	引用なし

	パスワード

γ様

ありがとうございます。

・ツリー全体表示


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

斉藤

- 16/12/17(土) 11:47 -


	引用なし

	パスワード

2002環境下で実ファイルで実行してみたところ、本当に申し訳ないのですが新たな問題が見つかりました。

現在のファイルには、「33Q10000000ttAp」というsheet名が付いており、他のシートは存在しない状態になっています。

実ファイルの方で実行すると、sheet2が無いためか「インデックスが有効範囲にありません」とエラーが表示されました。
そのため「result」というシートを作ってから、「result」sheetに結果を表示させるようにしたいのですが、ご教授頂けますでしょうか？

・ツリー全体表示


	【78691】Re:ランダムに提示

γ - 16/12/17(土) 11:35 -


	引用なし

	パスワード

▼戸梶さん：
>yさんのご指摘からしますと、bでお願いしたいです。
>よろしくお願いいたします。
よろしくと言われましても。

ワークシートに =RAND() 関数を入力して、
その乱数列でソートすればランダムに並びかわりますね。
その操作をマクロ記録すればよいだけなので、
お願いされる必要もないように思います。
ご自分でトライなさって、それでさらに不明な点を質問して下さい。

・ツリー全体表示


	【78690】Re:ランダムに提示

戸梶 - 16/12/17(土) 11:22 -


	引用なし

	パスワード

γさま

大変失礼いたしました。携帯から拝見した際にyと表示されていました。

ごめんなさい。

・ツリー全体表示


	【78689】Re:ランダムに提示

戸梶 - 16/12/17(土) 10:42 -


	引用なし

	パスワード

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

yさんのご指摘からしますと、bでお願いしたいです。

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

▼γ さん：
>たぶん出来ると思いますが、コードという前に確認です。
>
>(a)ランダムということは、時としてappleが続くこともあるわけですが、
>　それも許容するのですか？
>(b)それとも、いったん出てきたものは一巡するまでは重複して出さない前提ですか？
>
>(a)ならワークシート関数の RANDBETWEENを使うのが簡単です。
>(b)なら、予め１～ｎの数値をランダムに並び替えておいて、
>　上から順に使っていくのがよいでしょう。

・ツリー全体表示


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

斉藤

- 16/12/17(土) 10:11 -


	引用なし

	パスワード

▼β さん：

β さん、おはようございます。
sample3のプログラム本当にありがとうございました！
マルチで投稿していた質問は取り下げさせて頂きました。

sample3の動作は重複行の削除は実行でき、エラーはsample1と同様、Q列は表示されていない状況となりました。

2002の環境で実施する訳ではないので、本日、インターネットカフェなど別環境でsample1～3の動作確認を実施したいと思います。
それが動けば何の問題もないので、今の環境下の問題に関しては特にお調べ頂かなくて結構です。

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

・ツリー全体表示


	【78687】Re:ランダムに提示

γ - 16/12/17(土) 9:39 -


	引用なし

	パスワード

たぶん出来ると思いますが、コードという前に確認です。

(a)ランダムということは、時としてappleが続くこともあるわけですが、
　それも許容するのですか？
(b)それとも、いったん出てきたものは一巡するまでは重複して出さない前提ですか？

(a)ならワークシート関数の RANDBETWEENを使うのが簡単です。
(b)なら、予め１～ｎの数値をランダムに並び替えておいて、
　上から順に使っていくのがよいでしょう。

・ツリー全体表示


	【78686】ランダムに提示

戸梶 - 16/12/17(土) 8:43 -


	引用なし

	パスワード

よろしくお願いします。

あくまで例ですが，Sheet 2 に以下の情報が入力されています。1行目はタイトル行です。

A列には英単語，B列にはその日本語

apple りんご
banana バナナ
berry　ベリー

といった感じです。

子どもたちに Sheet 1 を見せて単語の練習を行いたいと考えています。
Sheet1上の開始ボタンを押すことで次の動作が始まります。

apple の文字列が図形四角に入って登場します。その5秒後に，その訳の「りんご」が同じように四角の図形に入って登場します。登場位置は appleの右側です。

その5秒後にbananaがappleの図形の下に同様の形式で登場し，その5秒後に「ばなな」が同様の形式で登場します。

この繰り返しです。

しかし私が考えていることは，これがランダムにできれば良いなと思っています。つまり，banana（とその訳）が最初に登場して，次に，berry（とその訳），次にapple（とその訳）といった感じで，開始ボタンを1回押すだけで，Sheet2に登録されている単語がシャッフルされて，Sheet1上に登場するというものです。

このようなことは可能でしょうか。ぜひコードをご教授いただけますでしょうか。

・ツリー全体表示


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

β - 16/12/17(土) 7:41 -


	引用なし

	パスワード

▼斉藤さん：

サロンのほうはマルチ禁止ですし、質問箱のルールでも　禁止しているサイトとのマルチはだめとなっていますので
サロンのほうに、質問取り下げの旨、コメントを入れ、解決マークをチェックして閉じておいてくださいね。

・ツリー全体表示


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

β - 16/12/17(土) 7:06 -


	引用なし

	パスワード

▼斉藤さん：

とりあえず　Sample2 のほうの　重複の削除を AdvancedFilter に変更したものを。
xl2002 のAdvancedFilter(フィルターオプション)は、それ以前の xl2000 や
それ以降の xl2003等　とは、少し機能が異なる部分がありますので、どうなるか
わかりませんが。
でも、これでも、その下のコードで Sample と同じエラーになるはずです。

Sub Sample3()
　　Dim c As Range
　　Dim dic As Object
　
　　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
　　　　.Range("Q1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
　　　　.Select
　　End With
　　
End Sub

・ツリー全体表示


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

β - 16/12/17(土) 6:48 -


	引用なし

	パスワード

▼斉藤さん：

xl2002ですか。
こちらにはその環境がないので確認はできないのですが、

・Sampleのほう、エラーは、
Range("Q1").Resize(dic2.Count).Value = WorksheetFunction.Transpose(dic2.items)

ここで発生したんですね。
う・・・ん、ちょっと調べてみますが、会社の xl2013 で処理するとどうなるか
教えてくださいね。

・Sample2 のほうは原因が明確です。

　.Columns("A:P").RemoveDuplicates Columns:=1, Header:=xlYes

これは xl2007で、初めてリリースされた機能ですので。
xl2002 であれば、これにかわるというか、代替手段として　AdvancedFilter　がありますけど
ここを AdvancedFilterに変更したとしても、その下に、Sampleでエラーになったコードと同じものがありますので。

これも会社の xl2013 で試してください。

・ツリー全体表示


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

斉藤

- 16/12/17(土) 1:28 -


	引用なし

	パスワード

▼β さん：

始めまして。
斉藤です。
このたびは2パターンも作って下さりありがとうございます！
なお、ルールに抵触してしまいました事、お詫び申し上げます。

会社のExcelは2013に対して、自宅のは古く2002を使っているのが原因だと思いますが･･･。

パターン1は、実行すると「型が一致しません。」とエラーとなり、
新しく作られたシートでは、A～Pまで重複行は1本にまとめられていますが、
Q列が空白となっています。

パターン2は、実行すると「オブジェクトは、このプロパティまたはメゾットをサポートしていません。」とエラーとなり、新しく作られたシートではA～Pは
表示されていますが、重複行は残ったままとなっており、またQ列も1と同様に
同じく空白となっています。

Q列のセルを確認しましたところ、2002では「標準」となっておりました。

引き続き、サポート頂けると助かります。

・ツリー全体表示


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

β - 16/12/16(金) 23:52 -


	引用なし

	パスワード

▼斉藤さん：

もう一例、A～Pを重複の削除機能で処理するパターンです。
8000件ぐらいなら、アップ済みのものとあまり効率はかわらないと思いますが。

Sub Sample2()
　　Dim c As Range
　　Dim dic As Object
　　Dim v As Variant
　　
　　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
　　　　.Range("Q1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
　　　　.Select
　　End With
End Sub

・ツリー全体表示


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

β - 16/12/16(金) 23:37 -


	引用なし

	パスワード

▼斉藤さん：

サロンはマルチ禁止しています。
質問箱のほうは許容していますが、差異との基本方針がありますので
熟読し、次回からは気を付けてください。

一例です。

Sub Sample()
　　Dim c As Range
　　Dim dic1 As Object
　　Dim dic2 As Object
　　
　　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))
　　　　.Range("Q1").Resize(dic2.Count).Value = WorksheetFunction.Transpose(dic2.items)
　　　　.Select
　　End With
　　
End Sub

・ツリー全体表示


	【78679】よろしくお願いいたします。

斉藤

- 16/12/16(金) 22:12 -


	引用なし

	パスワード

お世話になります。
会社でとあるデータを扱っているのですが、手処理が大変なのでなんとかしたいと考えています。

A～Qまでの列に各項目があり、全体で8000件弱のデータがあります。
1行目は見出しとなっています。

A列に6桁の番号があり、ソートされていない状態で、また部分的に重複があります。
重複は無いものもありますが、多いと10件以上重複しています。
重複しているデータのA～Pまでの列の情報は、すべて同じ情報です。

Q列には文字列があるので、重複しているデータはQ列のみカンマ区切りで結合し、
重複のない状態でこれを別のシートに、1行目は見出し付で表示させたいと思っています。

VBAで処理したいと考えていますが、結合の辺りで分からなくて途方に暮れています。
お助け頂けると、本当に助かります。
どうかよろしくお願い致します！

・ツリー全体表示


	【78678】Re:SetCurrentDirectoryでネットワーク上...

アソビン - 16/12/16(金) 12:19 -


	引用なし

	パスワード

▼亀マスターさん：

お返事が遅くなりまして申し訳ありません（レスが付いてもメールでの通知が来なかったもので…）。
ありがとうございます！FileDialogオブジェクトの方法を試してみた所、目的のディレクトリが表示されました！
と言ってもこれをカレントにするにはどうしたらいいのかまだイマイチわかっていないのですが、大きな前進だと思います。
これをヒントに自分で頑張ってみたいと思います。
大変お世話になりました！どうもありがとうございました！

>カレントディレクトリを移動させたいというのは、ファイル選択のダイアログで最初に表示されるディレクトリを指定したいということですよね。
>これまでの経過からして、アクセス権自体が怪しいので上手くいかない可能性が高い気がしますが、FileDialogオブジェクトも試してみてはどうでしょうか。
>
>
>'Microsoft Office ○○ Object Libraryの参照設定があるなら不要
>'○○はOfficeのバージョンによる数字
>Const msoFileDialogOpen As Long = 1
>
>With Application.FileDialog(msoFileDialogOpen)
>　　With .Filters
>　　　　.Clear
>　　　　.Add "Excel ファイル", "*.xls; *.xlsx", 1 '拡張子は必要に応じて変えてください
>　　End With
>　　.InitialFileName = "任意のディレクトリパス" '（例　\\ServerName\Sample\"）
>　　If .Show Then
>　　　　.Execute
>　　End If
>End With

・ツリー全体表示


	【78677】Re:処理速度を上げたい

北風 - 16/12/15(木) 18:11 -


	引用なし

	パスワード

▼β さん
何時も有難うざいます。
以下解答理解しました有難うございました。（If分は修正しました）

▼β さん：
>▼北風さん：
>
>とくにコード自体で大きな問題があるとは思えません。
>まぁ、処理に必要な時間なんじゃないですか。
>
>最初の　Columns("A:B").Select　は意味がないから不要とか
>With ActiveSheet.PageSetup　と End With のブロックが２回あるので
>まとめて一度の With で済むとか、　　
>With ActiveSheet.PageSetup としてセットしている項目が多いのに、
>ぽつんと、ActiveSheet.PageSetup.PrintArea = ""　と単独でやっているとか
>Columns("F:F").ColumnWidth = 9.5　といったコードを書いているのに
>　　Columns("C:E").Select
>　　Selection.ColumnWidth = 5.5
>こんなように、Select/Selectionベースで無駄な２行にしているところがあるとか
>
>そういうところはありますが、微々たるものですから。
>
>もちろん、PageSetup 領域には様々な設定項目があるわけで、
>マクロ記録をすると、規定値も含めてすべての項目の設定コードが生成されますが
>規定値については、設定コードをなくし、とくに指定したい項目のみに絞るというのは
>やってみられたらいいと思いますが。
>
>ところで、最後の
>
>If fs = False Then End
>
>もちろん、これでもいいのですが、 End ステートメントはできるだけ避けたほうがいいですよ。
>
>ふつうに
>
>If fs = False Then Exit Sub
>
>にしておかれたらいかがですか？

・ツリー全体表示


	【78676】Re:処理速度を上げたい

β - 16/12/15(木) 12:53 -


	引用なし

	パスワード

▼北風さん：

とくにコード自体で大きな問題があるとは思えません。
まぁ、処理に必要な時間なんじゃないですか。

最初の　Columns("A:B").Select　は意味がないから不要とか
With ActiveSheet.PageSetup　と End With のブロックが２回あるので
まとめて一度の With で済むとか、　　
With ActiveSheet.PageSetup としてセットしている項目が多いのに、
ぽつんと、ActiveSheet.PageSetup.PrintArea = ""　と単独でやっているとか
Columns("F:F").ColumnWidth = 9.5　といったコードを書いているのに
　　Columns("C:E").Select
　　Selection.ColumnWidth = 5.5
こんなように、Select/Selectionベースで無駄な２行にしているところがあるとか

そういうところはありますが、微々たるものですから。

もちろん、PageSetup 領域には様々な設定項目があるわけで、
マクロ記録をすると、規定値も含めてすべての項目の設定コードが生成されますが
規定値については、設定コードをなくし、とくに指定したい項目のみに絞るというのは
やってみられたらいいと思いますが。

ところで、最後の

If fs = False Then End

もちろん、これでもいいのですが、 End ステートメントはできるだけ避けたほうがいいですよ。

ふつうに

If fs = False Then Exit Sub

にしておかれたらいかがですか？

・ツリー全体表示


	【78675】処理速度を上げたい

北風 - 16/12/15(木) 12:04 -


	引用なし

	パスワード

下記マクロで処理していますがプレヴュー画面へ移行する時時間がかかるような気がします。処理速度を上げる方法はありますか。

Sub セルの値をファイル名にする()
Dim fm As String
Dim fs As Variant
ChDrive "S"
ChDir "S:\1ABT\1612\決定"
Columns("A:B").Select
With ActiveSheet.PageSetup
　　　　.PrintTitleRows = ""
　　　　.PrintTitleColumns = ""
　　End With
　　ActiveSheet.PageSetup.PrintArea = ""
　　With ActiveSheet.PageSetup
　　　　.LeftHeader = ""
　　　　.CenterHeader = ""
　　　　.RightHeader = ""
　　　　.LeftFooter = ""
　　　　.CenterFooter = ""
　　　　.RightFooter = ""
　　　　.LeftMargin = Application.InchesToPoints(0)
　　　　.RightMargin = Application.InchesToPoints(0)
　　　　.TopMargin = Application.InchesToPoints(0.984251968503937)
　　　　.BottomMargin = Application.InchesToPoints(0.984251968503937)
　　　　.HeaderMargin = Application.InchesToPoints(0.511811023622047)
　　　　.FooterMargin = Application.InchesToPoints(0.511811023622047)
　　　　.PrintHeadings = False
　　　　.PrintGridlines = False
　　　　.PrintComments = xlPrintNoComments
　　　　.PrintQuality = 600
　　　　.CenterHorizontally = False
　　　　.CenterVertically = False
　　　　.Orientation = xlPortrait
　　　　.Draft = False
　　　　.PaperSize = xlPaperA4
　　　　.FirstPageNumber = xlAutomatic
　　　　.Order = xlDownThenOver
　　　　.BlackAndWhite = False
　　　　.Zoom = 100
　　　　.PrintErrors = xlPrintErrorsDisplayed
　　End With

　　Columns("A:B").EntireColumn.AutoFit
　　Columns("C:E").Select
　　Selection.ColumnWidth = 5.5
　　Columns("F:F").ColumnWidth = 9.5
　　Columns("G:G").ColumnWidth = 8.25
　　Columns("G:G").EntireColumn.AutoFit
　　ActiveWindow.SelectedSheets.PrintPreview
　　ActiveWindow.SelectedSheets.PrintOut Copies:=1
With ThisWorkbook.ActiveSheet
　fm = .Range("A2").Text & "(" & .Range("F2").Text & ")"
End With
fs = Application.GetSaveAsFilename(fm, "MicrosoftExcelブック(*.xls),*.xls", , "ファイルを保存する", "保存")
If fs = False Then End
ThisWorkbook.SaveAs fs

End Sub

・ツリー全体表示


	【78674】Re:コードが黄色くなる

トキノハジメ - 16/12/14(水) 17:09 -


	引用なし

	パスワード

▼独覚さん：マナさん:rさん:βさん色々有難うございました。
これからよく見て記入いたします。

・ツリー全体表示


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

188 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free