Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
231 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【77825】メモリ不足の解消の仕方
質問  YUKI  - 16/1/6(水) 15:43 -
引用なし
パスワード
   いつもお世話になっております。解決策をご教授くださいませ。

シート16-30のデータをオートフィルターを使用してH行でソート、
ソートしたデータをシート1-15へデータを貼り付ける
（シート16はシート1、シート17はシート2へと順番に）
全部の記述を長いマクロで書いていた時は動いていたのですが、
繰り返しのマクロを使用して可読性を向上させようとしたところ
途中でメモリ不足になってしまうようになりました。
エラーで止まってしまうところまでは上手く動いているのですが･･･
手探りでネットを探して、見よう見まねで
DoEvents
Erase DynamicArray
の構文を入れてみましたが改善されず。お助けください･･･


Sub 貼り付け()
'
'
'
　　Application.ScreenUpdating = False
　　On Error Resume Next
　　
　　Dim i As Integer
　　　　
　　For i = 16 To 30
　　
　　
　　'
　　'
　　'3
　　Sheets(i).Select
　　Rows("41:41").Select
　　Selection.AutoFilter
　　Range("A41").CurrentRegion.AutoFilter Field:=8, Criteria1:="3"
　　Range("A41:F41").Select
　　Range(Selection, Selection.End(xlDown)).Select
　　Selection.Copy
　　Sheets(i - 15).Select
　　Range("A35").PasteSpecial Paste:=xlPasteValues
　　'
　　'4
　　Sheets(i).Select
　　Rows("41:41").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$41:$H$5000").AutoFilter Field:=8, Criteria1:="4"
　　Range("A41:F41").Select
　　Range(Selection, Selection.End(xlDown)).Select
　　Selection.Copy
　　Sheets(i - 15).Select
　　Range("Q35").PasteSpecial Paste:=xlPasteValues
　　'
　　'5
　　Sheets(i).Select
　　Rows("41:41").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$41:$H$5000").AutoFilter Field:=8, Criteria1:="5"
　　Range("A41:F41").Select
　　Range(Selection, Selection.End(xlDown)).Select
　　Selection.Copy
　　Sheets(i - 15).Select
　　'
　　'6
　　Sheets(i).Select
　　Rows("41:41").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$41:$H$5000").AutoFilter Field:=8, Criteria1:="6"
　　Range("A41:F41").Select
　　Range(Selection, Selection.End(xlDown)).Select
　　Selection.Copy
　　Sheets(i - 15).Select
　　'
　　'
　　'
　　'
　　Range("A32").Select
　　Sheets(i).Select
　　Rows("41:41").Select
　　Selection.AutoFilter
　　Range("A42").Select
　　DoEvents
　　Next
　　'
　　'
　　Erase DynamicArray
　　Sheets(16).Select
　　Application.ScreenUpdating = True
・ツリー全体表示
【77824】Re:msgboxでシートを指定する方法
発言  β  - 16/1/2(土) 20:21 -
引用なし
パスワード
   ▼ゆうすけ さん：

ダイアログが若干小さく、めだたないかもしれませんが
以下のような表示の仕方も。

Sub Sample2()
　　MsgBox "選択したいシートを選んでください"
　　CommandBars("Workbook tabs").ShowPopup
End Sub
・ツリー全体表示
【77823】Re:msgboxでシートを指定する方法
発言  β  - 16/1/2(土) 13:17 -
引用なし
パスワード
   ▼ゆうすけ さん：

MsgBoxでシートを指定する　という意味がいまいちわかりにくいのですが・・

提示されたコードでブックに対しては

・このブック名を開いてね　というメッセージをだしておいて
・ブック選択ダイアログを表示して
・操作者に開くべきブックをせんたくさせて
・そのブックをマクロで開く

こんな流れですね。
これをシートに当てはめると

・このシートを選んでね　というメッセージを出して
・シート一覧のようなものを表示して
・操作者にシートを指定させて
・マクロで、そのシートを選択する

こういったことを想定しておられるのでしょうか？

まず、（ブックもそうなんですが）選択すべきシートがわかっているなら
操作者に選ばせるまでもなく、マクロで直接、そのシートをSelectすれば
いいのでは？　と思うのですが。

そうではなく、選択すべきシートは、やはり、操作者に指定させないと
マクロでは判断できないということでしょうか？

であれば、γさんコメントの様に、たとえばユーザーフォームで
シート一覧を表示して選ばせるということも、よく使われる方法ですし、
以下のように、開きたいシートの任意のセルを選ばせるという手もあります。

Sub Sample()
　　Dim c As Range
　　
　　On Error Resume Next
　　Set c = Application.InputBox("目的のシートの任意のセルを選択してください", Type:=8)
　　On Error GoTo 0
　　
　　If c Is Nothing Then Exit Sub　 'キャンセルボタン
　　
　　c.Parent.Select
　　
End Sub
・ツリー全体表示
【77822】Re:点数のランキング
発言  γ  - 16/1/2(土) 7:27 -
引用なし
パスワード
   ▼まさひで さん：
>ロト6のデータベースを作成しています。過去の当選番号の6個数字を全て入力して、あるセルに当選の多かった数字ランキングベスト5と、それが何回当選されたのかを表示させたいのですが、何分にもかじりはじめで、ほとんど知識がなく分かりません。教えてくだされば幸いです。

詰まっているのはどこですか？
丸投げではなくて、困っているところを具体的に質問した方が
良いと思いますよ。

マクロでなくても、手作業で可能だと思います。
COUNTIF(データ範囲、数値）で数値がデータ範囲にいくつあるかを計算できます。
あとは普通に個数でソートすればいいですね。

余談ですけど、
一つの数値の出現回数がわかっても、６つの数値の組み合わせですからねえ。
練習問題かなにかですか？
・ツリー全体表示
【77821】Re:msgboxでシートを指定する方法
発言  γ  - 16/1/2(土) 7:19 -
引用なし
パスワード
   色々と方法はあるのでしょうけど、
例えば、ユーザーフォームを使ってはどうでしょうか。少し大げさか？
「ユーザーフォーム シート名」などでネット検索すると、
コードや作成方法を説明した記事が見つかりますよ。
・ツリー全体表示
【77820】msgboxでシートを指定する方法
質問  ゆうすけ  - 16/1/2(土) 2:03 -
引用なし
パスワード
   msgboxで「Aというファイルを開いてください」・・・1.
さらに「Bというシートを選択してください」・・2.
としたいです。

1.は
MsgBox "「A」を開いてください"
　　Dim OpenFileName As String
　　OpenFileName = Application.GetOpenFilename
　　　If OpenFileName <> "False" Then
　　　　Workbooks.Open OpenFileName
　　Else
　　　　MsgBox "キャンセルされました"
　　　　ThisWorkbook.Close False
　　End If

End Sub
で思うような形になりました。

2.（シート）を1.と同じように選択する方法はありますか。
・ツリー全体表示
【77819】Re:点数のランキング
発言  マナ  - 15/12/31(木) 23:08 -
引用なし
パスワード
   ▼まさひで さん：

１）データを１個ずつ辞書に登録
２）新規シートに登録結果を書き出し
３）回数の多い順に並べ替え
４）回数の多いものトップ５でフィルター

Sub test()
　　Dim dic As Object
　　Dim c As Range
　　
　　Set dic = CreateObject("scripting.dictionary")
　　
　　For Each c In Range("a1").CurrentRegion　　　'★データ範囲
　　　　dic(c.Value) = dic(c.Value) + 1
　　Next
　　
　　With Worksheets.Add
　　　　.Range("a1:b1").Value = Array("番号", "回数")
　　　　.Range("a2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
　　　　.Range("b2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
　　　　
　　　　With .Range("a1").CurrentRegion
　　　　　　.Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlYes
　　　　　　.AutoFilter Field:=2, Criteria1:="5", Operator:=xlTop10Items
　　　　End With
　　End With

End Sub
・ツリー全体表示
【77818】Re:至急お願い致します。
発言  β  - 15/12/31(木) 17:04 -
引用なし
パスワード
   ▼かん さん：

専門家さんならスマートかつすっきりした組み立てになると思いますが
泥臭く、積み木細工のように書けば

=QUOTIENT(A1,100)*100+MOD(A1,10)+MOD((A1-QUOTIENT(A1,100)*100-MOD(A1,10))+10,100)

とか。
・ツリー全体表示
【77817】点数のランキング
質問  まさひで  - 15/12/31(木) 14:53 -
引用なし
パスワード
   ロト6のデータベースを作成しています。過去の当選番号の6個数字を全て入力して、あるセルに当選の多かった数字ランキングベスト5と、それが何回当選されたのかを表示させたいのですが、何分にもかじりはじめで、ほとんど知識がなく分かりません。教えてくだされば幸いです。
・ツリー全体表示
【77816】Re:VBA素人です。至急お願いいたします。
お礼  kenkyu-sya  - 15/12/30(水) 17:22 -
引用なし
パスワード
   βさん

本を何冊か買ってきて、VBAの使い方を勉強している
最中です。

午前中は、エクセルのVBAをうまく使うことができなかったのですが
やっと少し理解できました。

βさんに作成していただいたものでうまく
作業できました。

本当にありがとうございました。
今後もどうかよろしくお願いいたします。
・ツリー全体表示
【77814】Re:至急お願い致します。
お礼  かん  - 15/12/30(水) 15:06 -
引用なし
パスワード
   ▼β さん：
>▼かん さん：
>
>単純に 10 を足しちゃだめなんですか？
>10の位はアップさせても、繰り上がりはさせず、100の位はそのままという要件ですか？

返信ありがとうございます。
そうです。一の位や百の位の数字は変えずに、10のくらいを繰り上げです。
位というか、下2桁目をひとつ繰り上げといったイメージです。
・ツリー全体表示
【77813】Re:至急お願い致します。
発言  β  - 15/12/30(水) 15:01 -
引用なし
パスワード
   ▼かん さん：

単純に 10 を足しちゃだめなんですか？
10の位はアップさせても、繰り上がりはさせず、100の位はそのままという要件ですか？
・ツリー全体表示
【77812】至急お願い致します。
質問  かん  - 15/12/30(水) 13:39 -
引用なし
パスワード
   エクセルで、任意の桁数を繰り上げしたいのですが、そういった関数はあります
でしょうか。

例
3322501　　　3322511
3322601　　→3322611
3322711　　　3322721

10のくらいのみをひとつ繰り上げて、一の位はそのままにしたいのですが。
よろしくお願いいたします。
・ツリー全体表示
【77811】Re:VBA素人です。至急お願いいたします。
発言  β  - 15/12/30(水) 12:36 -
引用なし
パスワード
   ▼kenkyu-sya さん：

もう１つ。
アップされたレイアウト、"USERID" が A1、"問５" が F1 という前提です。
・ツリー全体表示
【77810】Re:VBA素人です。至急お願いいたします。
発言  β  - 15/12/30(水) 12:34 -
引用なし
パスワード
   ▼kenkyu-sya さん：

>すぐに試してみたのですが、うまく実行できておりません。

具体的には、どのような不具合があったのでしょうか？

>具体的には、コピーアンドペーストをしたシートの実行と
>保存がうまくいっていません。

この意味がよくわかりません。

いずれにしてもアップしたコードは標準モジュールというところに書きます。
また、実行時には変換しようとしているシートを表示して実行することを前提にしています。
・ツリー全体表示
【77809】Re:VBA素人です。至急お願いいたします。
発言  β  - 15/12/30(水) 11:49 -
引用なし
パスワード
   ▼kenkyu-sya さん：

アップ済みのコードと基本かわりませんが、処理効率を若干あっぷさせたものも参考までに。

Sub Test2()
　　Dim r As Range
　　Dim a As Range
　　Dim f As Range
　　Dim t As Range
　　
　　Application.ScreenUpdating = False
　　
　　With Range("A1").CurrentRegion
　　　　With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
　　　　　　For Each r In .Rows
　　　　　　　　On Error Resume Next
　　　　　　　　Set a = r.SpecialCells(xlCellTypeConstants)
　　　　　　　　On Error GoTo 0
　　　　　　　　If Not a Is Nothing Then
　　　　　　　　　　If a.Areas.Count > 1 Then
　　　　　　　　　　　　Set f = a.Areas(1).Cells(1)
　　　　　　　　　　　　Set t = a.Areas(a.Areas.Count).Cells(a.Areas(a.Areas.Count).Cells.Count)
　　　　　　　　　　　　Range(f, t).Value = f.Value
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　End With
End Sub
・ツリー全体表示
【77808】Re:VBA素人です。至急お願いいたします。
お礼  kenkyu-sya  - 15/12/30(水) 11:49 -
引用なし
パスワード
   βさん

お忙しい中レスをいただきありがとうございました。

すぐに試してみたのですが、うまく実行できておりません。
素人ですのでもう少しお時間をもらえればと思います。
具体的には、コピーアンドペーストをしたシートの実行と
保存がうまくいっていません。
またうまくいきましたらお返事させていただこうとおもいます。

ありがとうございました。


▼β さん：
>▼kenkyu-sya さん：
>
>質問に回答をもらってからのほうがいいかとも思いますが、推測で。
>
>Sub Test()
>　　Dim r As Range
>　　Dim a As Range
>　　Dim f As Range
>　　Dim t As Range
>　　With Range("A1").CurrentRegion
>　　　　With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
>　　　　　　For Each r In .Rows
>　　　　　　　　On Error Resume Next
>　　　　　　　　Set a = r.SpecialCells(xlCellTypeConstants)
>　　　　　　　　On Error GoTo 0
>　　　　　　　　If Not a Is Nothing Then
>　　　　　　　　　　Set f = a.Areas(1).Cells(1)
>　　　　　　　　　　Set t = a.Areas(a.Areas.Count).Cells(a.Areas(a.Areas.Count).Cells.Count)
>　　　　　　　　　　Range(f, t).Value = f.Value
>　　　　　　　　End If
>　　　　　　Next
>　　　　End With
>　　End With
>End Sub
・ツリー全体表示
【77807】Re:VBA素人です。至急お願いいたします。
回答  kenkyu-sya  - 15/12/30(水) 11:10 -
引用なし
パスワード
   返信ありがとうございます


＞問１と問３と問５に回答していればどういった結果になりますか？
まれにこういうことはあると思うのですが、問２と問４は回答しているという
扱いにします。

＞また、これは、こちらがとやかくいうことではありませんけど
＞本当に、問１と問５だけに回答。　問２〜問４は未回答だったということはないのでし＞ょうかねぇ？
そうなんです。未回答で空白扱いになっております。
しかし、今回は、こういうオセロみたいに挟んだものだけは回答したものとして
扱いたいのです。

今からいただいたレスを使ってみようと思います。

お忙しいところ、レスありがとうございました。
・ツリー全体表示
【77806】Re:VBA素人です。至急お願いいたします。
発言  β  - 15/12/30(水) 10:48 -
引用なし
パスワード
   ▼kenkyu-sya さん：

質問に回答をもらってからのほうがいいかとも思いますが、推測で。

Sub Test()
　　Dim r As Range
　　Dim a As Range
　　Dim f As Range
　　Dim t As Range
　　With Range("A1").CurrentRegion
　　　　With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
　　　　　　For Each r In .Rows
　　　　　　　　On Error Resume Next
　　　　　　　　Set a = r.SpecialCells(xlCellTypeConstants)
　　　　　　　　On Error GoTo 0
　　　　　　　　If Not a Is Nothing Then
　　　　　　　　　　Set f = a.Areas(1).Cells(1)
　　　　　　　　　　Set t = a.Areas(a.Areas.Count).Cells(a.Areas(a.Areas.Count).Cells.Count)
　　　　　　　　　　Range(f, t).Value = f.Value
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　End With
End Sub
・ツリー全体表示
【77805】Re:VBA素人です。至急お願いいたします。
発言  β  - 15/12/30(水) 10:38 -
引用なし
パスワード
   ▼kenkyu-sya さん：

仮に　問１と問３と問５に回答していればどういった結果になりますか？

また、これは、こちらがとやかくいうことではありませんけど
本当に、問１と問５だけに回答。　問２〜問４は未回答だったということはないのでしょうかねぇ？
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
231 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free