アレルギー対策、自宅でできる効果的な方法とは?

お世話になります。
フォームの今月ボタンを押したら、納品日の今月のデータだけが抽出されるようにコードを設定したいのですが、上手くいきません。アドバイスください。よろしくお願いします。

Private Sub 今月_Click()
Me.Filter = "納品日 Between #" & Nz(DateSerial(Year(Date), Month(Date), 1), "1900/1/1") & "# And #" & Nz(DateSerial(Year(Date), Month(Date) + 1, 0), "9999/12/31") & "#"
End Sub

A 回答 (2件)

Me.Filter = "・・・"



の次に

Me.FilterOn = True

を付け加えてみては?
    • good
    • 0
この回答へのお礼

お返事遅くなりすみません。
アドバイス頂いた通り入力したら出来ました!!
悩んでいたので感謝です。ありがとうございました。

お礼日時:2017/06/19 08:58

"納品日 Between #"を"[納品日] Between #"にするとどうですか?

    • good
    • 0
この回答へのお礼

お返事ありがとうございます!
試してみましたが何も変化しませんでした。
もう少し色々試してみます。

お礼日時:2017/06/16 15:09

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aと関連する良く見られている質問

Qマクロを組んだエクセルのデータを別のエクセルにコピペしたことが原因で・・・

win7使用してます。以前に,アクティブセルの行と列に十文字のラインが入るようにネットで調べたマクロを入力してみました。そのせいなのだと思うのですが,そのデータを別のエクセルにコピペして使うのですが,そのコピペ先のエクセルシートのセルがランダムに青くなるようになりました。
範囲選択をしてその青い部分を覆うと,消えたり消えなかったりしたり,いったん画面外にスクロールし戻ると消えていたり・・そのままも。枠だけが水色(この色はコピペ元のシートで入力したマクロで指定した色)になったりもします。これも同様,消えたり現れたりを繰り返します。恐らくマクロを組んだシートのデータなので,何か余分なものまで持ってきてしまっているような状態なのだと思います。いろいろ調べていますが同じ症例が見当たらず,改善策を教えて頂きたく質問させて頂きました。
有識の方よろしくお願いします。

Aベストアンサー

No.1 の追補

標準モジュールではなくシートモジュールやワークブックモジュールにコードは残っていませんか?
下図の赤く囲まれた部分をクリックしてみてください。

QVBA コンパイルエラーの解消法

皆様、いつもお世話になっております。
初心者なりに考えてVBAを組んでみたのですが、「Sub または Fanction が定義されていません」とエラー表示が出てきます。
自分なりにコードに間違いがないか検索ながらやってみたのですが、うまくいきません。

どなたか、知恵をお貸しいただけないでしょうか。



テーブルの入っているSheet1から、シート”施工体制台帳~”の該当するセルにデータのコピーを行うためのVBAです。
業者の数だけループするように組んだつもりなのですが、エラー表示のため実行ができません。
ご指摘、よろしくお願いいたします。

Sub kopipe1() '施工体制台帳
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim sb As Long
Dim m As Long
Dim p As Long
Dim c As Long
Dim i As Long
Dim end1 As Long

Set sh = Worksheet("sheet1")
Set sh1 = Worksheet("施工体制台帳 (下請け) ")


end1 = sh.Range(".Cells(Rows.Count, 2)").End(xlUp)
sb = 1
p = 1

For i = 2 To end1 Step 1
sb = sb + 1
c = cell(p, 9)

sh.cell(sb, 2).Copy Destination:=.sh1.Range(c).Offset(2, 1) '会社名
sh.cell(sb, 3).Copy Destination:=.sh1.Range(c).Offset(2, 27) '代表者名
sh.cell(sb, 4).Copy Destination:=.sh1.Range(c).Offset(4, 1) '郵便番号
sh.cell(sb, 5).Copy Destination:=.sh1.Range(c).Offset(5, 1) '住所
sh.cell(sb, 6).Copy Destination:=.sh1.Range(c).Offset(6, 24) '電話番号
sh.cell(sb, 7).Copy Destination:=.sh1.Range(c).Offset(13) '業種1
sh.cell(sb, 8).Copy Destination:=.sh1.Range(c).Offset(14, 12) '許可者1
sh.cell(sb, 9).Copy Destination:=.sh1.Range(c).Offset(14, 15) '区分1
sh.cell(sb, 10).Copy Destination:=.sh1.Range(c).Offset(14, 17) '許可1-1
sh.cell(sb, 11).Copy Destination:=.sh1.Range(c).Offset(14, 20) '許可1-2
sh.cell(sb, 12).Copy Destination:=.sh1.Range(c).Offset(14, 27) '許可年月日
sh.cell(sb, 13).Copy Destination:=.sh1.Range(c).Offset(16) '業種2
sh.cell(sb, 14).Copy Destination:=.sh1.Range(c).Offset(17, 12) '許可者2
sh.cell(sb, 15).Copy Destination:=.sh1.Range(c).Offset(17, 15) '区分2
sh.cell(sb, 16).Copy Destination:=.sh1.Range(c).Offset(17, 17) '許可2-1
sh.cell(sb, 17).Copy Destination:=.sh1.Range(c).Offset(17, 20) '許可2-2
sh.cell(sb, 18).Copy Destination:=.sh1.Range(c).Offset(17, 27) '許可年月日2
sh.cell(sb, 19).Copy Destination:=.sh1.Range(c).Offset(21, 28) '健康保険
sh.cell(sb, 20).Copy Destination:=.sh1.Range(c).Offset(22, 28) '厚生年金保険
sh.cell(sb, 21).Copy Destination:=.sh1.Range(c).Offset(23, 28) '雇用保険
sh.cell(sb, 22).Copy Destination:=.sh1.Range(c).Offset(25, 3) '現場代理人指名
sh.cell(sb, 23).Copy Destination:=.sh1.Range(c).Offset(29, 7) '主任技術者氏名
sh.cell(sb, 24).Copy Destination:=.sh1.Range(c).Offset(31, 3) '資格内容
sh.cell(sb, 25).Copy Destination:=.sh1.Range(c).Offset(33, 3) '安全衛生責任者
sh.cell(sb, 26).Copy Destination:=.sh1.Range(c).Offset(25, 26) '安全衛生推進者
sh.cell(sb, 27).Copy Destination:=.sh1.Range(c).Offset(27, 26) '雇用管理責任者
sh.cell(sb, 28).Copy Destination:=.sh1.Range(c).Offset(29, 26) '専門技術者名
sh.cell(sb, 29).Copy Destination:=.sh1.Range(c).Offset(31, 26) '技術資格内容

p = p + 62
Exit For
Next i
End Sub

皆様、いつもお世話になっております。
初心者なりに考えてVBAを組んでみたのですが、「Sub または Fanction が定義されていません」とエラー表示が出てきます。
自分なりにコードに間違いがないか検索ながらやってみたのですが、うまくいきません。

どなたか、知恵をお貸しいただけないでしょうか。



テーブルの入っているSheet1から、シート”施工体制台帳~”の該当するセルにデータのコピーを行うためのVBAです。
業者の数だけループするように組んだつもりなのですが、エラー表示...続きを読む

Aベストアンサー

今のところ、変数に代入する以外のコードはほとんど間違っているわけですから、どれがどうと言えないと思います。
他の方との重複を含みます。
・Worksheet(---) ->Worksheets(----)
・sh.Range(".Cells(Rows.Count, 2)").End(xlUp)
  ↓
sh.Cells(Rows.Count, 2).End(xlUp).Row
・c = cell(p, 9)
  ↓
 c = Cells(p, 9) ただし、最後に、p = p + 62の後、Exit For では、1回キリでおしまいになってしまいます。

おそらくは、Dim c As String --Cells(p, 9).Address(0,0)
のはずです。
 
・sh.cell(sb, 2).Copy Destination:=.sh1.Range(c).Offset(2, 1) '会社名
とりあえず、Cells と sh1 のコンマは取るけれども、
sh1.Range(c).Offset(2, 1) これでは可読性を落とすばかりで分かりません。

これ自体を直すよりは、最初から作り直したほうが早そうです。
たぶん、一覧で横に並んでいるものを、別のシートの各場所に振り替えていくわけで、それが、ページごとになっているというわけでしょう。

まず、 sh1.cells(sb, 2).Copy ですが、
その列の2 を変数にすべきですね。

受ける側が、Offset で書かれてしまうと、手がつけられなくなってしまいます。

sh1.Range("J3,AJ3,J5,J6,AG7,I14,U15,X15,Z15,AC15,AJ15,I17," & _
 "U18,X18,Z18,AC18,AJ18,AK22,AK23,AK24,L26,P30,L32,L34," & _
 "AI26,AI28,AI30,AI32")

このようにまとめてしまい、以下のように纏めたものから呼び出すようにします。
しかし、実際にやってみると不具合が生じるので、それを配列で渡すようにします。

注:以下は、私の想像で書かれたものであって、実際に合っているのかは分かりません。
このようなスタイルにしてみたらという、あくでもこちらの提案です。

'//
Sub Test1()
 Dim Rng As Range
 Dim i As Long, j As Long, sb As Long
 Dim c As Variant
 Dim sh As Worksheet, sh1 As Worksheet
 Set sh = Worksheets("sheet1")
 Set sh1 = Worksheets("施工体制台帳 (下請け)")

 
 Set Rng = sh1.Range("J3,AJ3,J5,J6,AG7,I14,U15,X15,Z15,AC15,AJ15,I17," & _
 "U18,X18,Z18,AC18,AJ18,AK22,AK23,AK24,L26,P30,L32,L34," & _
 "AI26,AI28,AI30,AI32")
 
 end1 = sh.Cells(Rows.Count, 2).End(xlUp).row
 
 i = 2
 sb = 2
 For j = 1 To end1
 a = (j - 1) * 62 + 1
  For Each c In Rng.Offset((j - 1) * 62 + 1)
   c.Value = sh.Cells(sb, i).Value
   DoEvents
   i = i + 1
  Next
  i = 2
  sb = sb + 1
 Next
End Sub

今のところ、変数に代入する以外のコードはほとんど間違っているわけですから、どれがどうと言えないと思います。
他の方との重複を含みます。
・Worksheet(---) ->Worksheets(----)
・sh.Range(".Cells(Rows.Count, 2)").End(xlUp)
  ↓
sh.Cells(Rows.Count, 2).End(xlUp).Row
・c = cell(p, 9)
  ↓
 c = Cells(p, 9) ただし、最後に、p = p + 62の後、Exit For では、1回キリでおしまいになってしまいます。

おそらくは、Dim c As String --Cells(p, 9).Address(0,0)
のはずです。
 
・sh.cell(sb, 2).C...続きを読む

QEXCEL VBAでPDFファイルを開いて印刷

Excel VBAで指定してフォルダのPDFファイルを開いて印刷したいです(できれば閉じるところまで)。
開くところまではできたのですが、その先に印刷するのはどのようにしたら良いか教えてください。
安直な考えで開いた後のコードに何か付け足せばいけるのかと思って色々調べてはみたのですが、
そもそも開く段階で別のコマンドを指定しないといけないのでしょうか。
ちなみに、フォルダは変動しませんがファイル名はA1に入っている文言を拾うようにしています。

現在のコード
Sub printpdf()
Dim keyword As String
Dim myPath As String
Dim fName As String

keyword = Worksheets("Sheet1").Range("A1").Value
myPath = "\\フォルダのパス\"
fName = Dir(myPath & keyword & ".pdf")

If fName = "" Then
MsgBox ("該当するファイルが存在しません。")
Exit Sub
End If

Shell ("explorer.exe " & myPath & fName)
fName = Dir()
End Sub

Excel VBAで指定してフォルダのPDFファイルを開いて印刷したいです(できれば閉じるところまで)。
開くところまではできたのですが、その先に印刷するのはどのようにしたら良いか教えてください。
安直な考えで開いた後のコードに何か付け足せばいけるのかと思って色々調べてはみたのですが、
そもそも開く段階で別のコマンドを指定しないといけないのでしょうか。
ちなみに、フォルダは変動しませんがファイル名はA1に入っている文言を拾うようにしています。

現在のコード
Sub printpdf()
Dim key...続きを読む

Aベストアンサー

#4の回答者です。

>ちなみにプリンターバッファの問題とはバッファにデータが残ってしまうのでしょうか?

ある一定量を越えると、プリンターがうんともすんとも反応しなくなってしまうことがありました。マクロはすごく速く処理してしまうのに、プリンターのほうは、実際に印刷時間がありますから、ギャップがあるのです。

Sleep 1000  '1秒
------------------
cnt = cnt + 1
If cnt > 100 Then Exit Sub

で、ほんのちょっとの時間稼ぎはしています。
ちなみに、
If cnt > 100 Then Exit Sub 
これは、ハンドルが取れない時の保護処理です。

なお、sendkeys は、例えば、エクセルで発生させると、エクセル内に関しては、うまくいくこともありますが、外部には働かないことが多いです。
もし、Sendkeys を試すなら、
  CreateObject("Wscript.Shell").SendKeys "%{F4}"
を試してみることですね。

>キーワードが頭に無い為調べ方すら分からないレベルだったので勉強になりました。
そういう私も、もう一度勉強し直します。WMで始まる命令って4個ぐらいしかないのですが、実は、他の定数で、もっと一杯あることを最近知りました。ネット検索でも、ぜんぜん出てこないのですね。(探し方にVB限定で検索するのが、問題があるようです)

#4の回答者です。

>ちなみにプリンターバッファの問題とはバッファにデータが残ってしまうのでしょうか?

ある一定量を越えると、プリンターがうんともすんとも反応しなくなってしまうことがありました。マクロはすごく速く処理してしまうのに、プリンターのほうは、実際に印刷時間がありますから、ギャップがあるのです。

Sleep 1000  '1秒
------------------
cnt = cnt + 1
If cnt > 100 Then Exit Sub

で、ほんのちょっとの時間稼ぎはしています。
ちなみに、
If cnt > 100 Then Exit Sub 
これは...続きを読む

QExcelでVBAを利用しているときのエラー処理について

Sub 料金判定()

Dim a As Worksheet
Dim s As Worksheet
Set a = Sheets("メモ作成")
Set s = Sheets("料金プラン")

Range("C12").Value = WorksheetFunction.Index(s.Range("$B$2:$B$23"), WorksheetFunction.Match(a.Range("$B$12"), s.Range("$A$2:$A$23"), 0))

End Sub


上記コードで反応するのですが、参照する値がない場合、エラーになりますが、その時に
C12に無と表示させたいのですが、

Range("C12").Value = WorksheetFunction.IsError(WorksheetFunction.Index(s.Range("$B$2:$B$23"), WorksheetFunction.Match(a.Range("$B$12"), s.Range("$A$2:$A$23"), 0), "無"))

上記だとエラーが表示されます。

このコードの修正箇所をご教示お願いします。

Sub 料金判定()

Dim a As Worksheet
Dim s As Worksheet
Set a = Sheets("メモ作成")
Set s = Sheets("料金プラン")

Range("C12").Value = WorksheetFunction.Index(s.Range("$B$2:$B$23"), WorksheetFunction.Match(a.Range("$B$12"), s.Range("$A$2:$A$23"), 0))

End Sub


上記コードで反応するのですが、参照する値がない場合、エラーになりますが、その時に
C12に無と表示させたいのですが、

Range("C12").Value = WorksheetFunction.IsError(WorksheetFunction.Index(s.Range("$B...続きを読む

Aベストアンサー

コード自体への突っ込みはやめておきます。
とりえあえず やりたいのは「IsError」ではなく「IfError」では?

QVBAでマクロを組んでいますが、エラーが起きてしまいます。

VBAでマクロを組もうとしています。
作ろうとしているのは、フォルダを指定すると、そのフォルダの中に入っているワークブック全てのシートから特定の名前のシートだけ、別のブックにコピーされるというものです。
(例 1というフォルダの中にあ、い、うの3つのワークブックが入っているとすると、その3つのワークシートからAという名前のシートのみコピーされて、えという名前のワークブックにまとめられる。)

プログラムに関して初心者のため手探りで組んでみたのですが、「オブジェクト変数が…」というエラーが出てしまいます。

どこに原因があるのか教えていただけませんか。
コピペしたため改行など変かもしれません。
すみません。



Sub Sample()
Dim sFile As String
Dim sWB As Workbook, dWB As Workbook
Dim dSheetCount As Long
Dim sSheetCount As Long
Dim n As Integer
Dim i As Long

Const SOURCE_DIR As String = "C:\Users\A
Const DEST_FILE As String = "C:\Users\B.xls"

Dim sWork As Worksheet
Dim dWork As Worksheet

Dim tmp As Variant



Application.ScreenUpdating = False


sFile = Dir(SOURCE_DIR & "*.xls")
'SOURCE_DIR=「A」ファイルでその中に入ってるブックの名前を sFile とする

'フォルダ内にブックがなければ閉じる
If sFile = "" Then Exit Sub

'コピー先のブックを作成。dWBという名前のブックを加える。
Set dWB = Workbooks.Add

'dWBのシート数を取得。コピー先のシート数を表すときはdSheetCountを使う。
'コピー元のシート数はsSheetCountを使う。

dSheetCount = dWB.Worksheets.Count
sSheetCount = sWB.Worksheets.Count

Do
'コピー元のブックを開く
Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)


'コピー元のファイルに「りんご」という文字があるか確認する。
'もし文字があったらコピー先のブックにコピーする。

'コピー元のワークシート数の何番目なのか表記はnで表す。
'コピー元のワークシートのことをsWorkと表す。
'コピー先のワークシートのことをdWorkと表す。

Set sWork = sWB.Worksheets
Set dWork = dWB.Worksheets

For n = 1 To sWB.Worksheets.Count
If InStr("sWork(sSheetsCount).name", "りんご") <> 0 Then
sWork("りんご").Copy After:=dWB.Worksheets(dSheetCount)

'コピー先のシート名をコピー元のブックの名前に置き換える
'コピー先のシート数+1の数だけシートを確認して、
'「りんご」という文字があったものだけ置き換える。
For i = 1 To dSheetCount + 1
If InStr("dWork(i).name", "りんご") <> 0 Then

'置き換える名前はコピー元のブック名を_で区切った(1)にあたるものにする。
tmp = Split("sWb.Name", "_")
dWork(i).Name = tmp(1)
End If
Next
End If
Next



'コピー元ファイルを保存しないで閉じる。

'ワークブック"Book1.xls"を保存しないで閉じる
'Sub CloseWorkbook()
'Workbooks("Book1").Close SaveChanges:=False
'End Sub
sWB.Close SaveChanges:=False



'次のブックのファイル名を取得
sFile = Dir()
Loop While sFile <> ""

'コピー先ブック作成時にあったシートを削除
Application.DisplayAlerts = False
For i = dSheetCount To 1 Step -1
dWB.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True

'コピー先ブックを保存して閉じる
dWB.SaveAs Filename:=DEST_FILE
dWB.Close

Application.ScreenUpdating = False
End Sub

VBAでマクロを組もうとしています。
作ろうとしているのは、フォルダを指定すると、そのフォルダの中に入っているワークブック全てのシートから特定の名前のシートだけ、別のブックにコピーされるというものです。
(例 1というフォルダの中にあ、い、うの3つのワークブックが入っているとすると、その3つのワークシートからAという名前のシートのみコピーされて、えという名前のワークブックにまとめられる。)

プログラムに関して初心者のため手探りで組んでみたのですが、「オブジェクト変数が…」という...続きを読む

Aベストアンサー

>>dWBについてもdSheetcountとしているので、ActiveWorkbookとおこうとしたのですが、「オブジェクトはこのプロパティ、またメソッドをサポートしていない」と出てしまいました。


dWBはアウトプットするワークブック名であり既に
Set dWB = Workbooks.Add
とやってるから追加記述は要りません。

QACCESS VBA 文字抽出について 文字の抽出をVBAにて行いたいのですが教えてください テキス

ACCESS VBA 文字抽出について

文字の抽出をVBAにて行いたいのですが教えてください

テキストボックス1に170626と入力を行う
その際必ず数値が6ケタしか入力できないようにする
6桁入力が完了すると、自動で
テキストボックス2に17
テキストボックス3に06
テキストボックス4に26
と分けて抽出を行う
このような仕様にしたいのですが可能でしょうか?

Aベストアンサー

>その際必ず数値が6ケタしか入力できないようにする

テキストボックス1のプロパティシート、データタブの入力規則に「Len([テキストボックスの名前])=6」
とすればよいです。6文字以外の時にメッセージを足したい場合は、その下のエラーメッセージ欄に
例えば「6文字で入力してください」とか記述すれば6文字以外の場合はメッセージが出ます。

抽出は、テキストボックス1の更新後処理イベントに以下のコードを書いてみてください。

Me.テキストボックス2 = Left(Me.テキストボックス1, 2)
Me.テキストボックス3 = Mid(Me.テキストボックス1, 3, 2)
Me.テキストボックス4 = Right(Me.テキストボックス1, 2)

6文字チェックもVBAで行うなら

If Len(Me.テキストボックス1) <> 6 Then
MsgBox "6文字で入力してください"
ELSE
 ※上記のコード
End If

QACCESS フォームでの期間抽出の方法を教えてください

テキストBOXを2つ使用してその2つの値の期間を満たす条件を抽出したいのですが・・・。
それと今月・先月分のボタンを作成し、今月・先月分が抽出されるようにも作りたいのですが、どんなコードをつかえばいいでしょうか?

漠然とした質問ですがよろしくお願いします

Aベストアンサー

日付フィールドがyyyy/mm/ddであるとして
抽出用のコマンドボタンを作成して
Me.Filter = "日付 Between #" & Nz(開始,"1900/1/1") & "# And #" & Nz(終了,"9999/12/31") & "#"

今月分なら
開始 = DateSerial(Year(Date),Month(Date),1)
終了 = DateSerial(Year(Date),Month(Date)+1,0)
先月分なら
開始 = DateSerial(Year(Date),Month(Date)-1,1)
終了 = DateSerial(Year(Date),Month(Date),0)
で期間をセットしてください。

QVBAのオートフィルターで該当行がない場合に処理を止めたい

マクロの記録から下記のマクロを作成しました。R列に該当データがある場合は正常に処理されますが、なかった場合、E2:M407、E448:M1035 の全データが削除されてしまいます。
R列にAC2のデータがなかった場合に処理を中止する方法を教えてください。

Sub Macro1()

Application.ScreenUpdating = False
  a = Range("AC2")
Range("E2:M407").Select
ActiveSheet.Range("$A$1:$Y$1666").AutoFilter Field:=18, Operator:= _
xlFilterValues, Criteria2:=Array(1, a)
Selection.ClearContents

ActiveSheet.Range("$A$1:$Y$1666").AutoFilter Field:=18

Range("E448:M1035").Select
ActiveSheet.Range("$A$1:$Y$1666").AutoFilter Field:=18, Operator:= _
xlFilterValues, Criteria2:=Array(1, a)
Selection.ClearContents

ActiveSheet.Range("$A$1:$Y$1666").AutoFilter Field:=18

Application.ScreenUpdating = True
End Sub

マクロの記録から下記のマクロを作成しました。R列に該当データがある場合は正常に処理されますが、なかった場合、E2:M407、E448:M1035 の全データが削除されてしまいます。
R列にAC2のデータがなかった場合に処理を中止する方法を教えてください。

Sub Macro1()

Application.ScreenUpdating = False
  a = Range("AC2")
Range("E2:M407").Select
ActiveSheet.Range("$A$1:$Y$1666").AutoFilter Field:=18, Operator:= _
xlFilterValues, Criteria2:=Array(1, a)
Selection.ClearContents

Active...続きを読む

Aベストアンサー

No.1です。

お手元の配置が判らないのですが・・・

>Selection.ClearContents


On Error Resume Next
Selection.SpecialCells(xlCellTypeVisible).ClearContents

としたらどうなりますか?m(_ _)m

Qエクセルで同じデータのかたまりの中で仲間はずれを探す方法

エクセルで、A列にグループ化された文字列があって、B列に数値がある場合、A列が同じ値でB列が同じではない判定はどのようにすればいいでしょうか。
下記の場合、B2とB7が仲間はずれだと知りたいのです。

ご教示いただけますと幸いです。よろしくお願いいたします。

A列 B列
1 AAAA 20170101
2 AAAA 20170102 *仲間はずれ
3 AAAA 20170101
4 AAAA 20170101
5 BBBB 20170103
6 BBBB 20170103
7 BBBB 20170101 *仲間はずれ
8 BBBB 20170103
9 CCCC 20170101

Aベストアンサー

No.2です。

>残念ながらひとつ以上ありそうなんです・・・

少数派の一番数の少ないときに「仲間はずれ」と表示させるようにしてみました。
多数派と少数派 ← 厳密には言い回しが違うかもしれませんが・・・
同数の場合は何も表示されません。

↓の画像のように作業用の列を1列設けてみてはどうでしょうか?
作業列D2セルに
=IF(COUNTIF(A:A,A2)>1,COUNTIFS(A:A,A2,B:B,B2),"")
という数式を入れフィルハンドルでずぃ~~~!っと下へコピーしておき
C2セルに
=IF(AND((D2=MAX(IF(A$2:A$1000=A2,D$2:D$1000)))<>(D2=MIN(IF(A$2:A$1000=A2,D$2:D$1000))),D2=MIN(IF(A$2:A$1000=A2,D$2:D$1000))),"仲間はずれ","")
配列数式なのでCtrl+Shift+Enterで確定!
フィルハンドルで下へコピー!

これで画像のような感じになります。m(_ _)m

Qエクセルのバージョンアップによるマクロ不調

エクセル2007にて、for...next構文を含むマクロをフォームボタンに登録し使用していました。
カウンタ変数に3から25を代入しています。
(3行目から25行目を処理するため)

しかしエクセル2016にパソコンが変わり、ボタンを押すと3行目だけ処理しマクロが終わってしまいます。
ボタンを押す代わりに、VBEから直接実行すると問題なく最後まで繰り返し処理されます。

バージョンアップにより何か不都合があるのでしょうか。お教え下さい。

Aベストアンサー

#2の回答者です。
長文でまとまっていませんが、私の考えたレポートです。

こちらは、Excel 2013ですが、一応、通して動かしてみて完結はするのですが、途中、何か良くわからない動きがあります。このコードには、どちらかというと「気になる」の部分はあります。しかし、それ以上に、ハングしたかなって思わせるような状態で、マクロが終了しているのです。それが何か今のところは分かりません。
どうも、ステップで進める分には、まったくその問題はみられません。

そのコードで問題になる部分は、2つですが、結論からすると、直しても変わりませんでした。
> Dim h As Integer 'データ集積シートの最終行
これは、Integer ではなくて、Long 型のほうがよいです。
ついでに、Dim i As Long '入力表シートの行数 もLong型のほうがよいのは、PCの扱うデータは、32bit が主なので、Integer 型は、一旦、Long型に変換しているので、なるべく、Integer 型は使わないほうがよいとしています。

>h = Worksheets("集積_税制").Range("A65536").End(xlUp).Row + 1
これは、最初、ループの外で行って、書き込みが完了したら、
h = h+1

とします。ただ、それでも、問題はほとんど改善されませんでした。
ふつうは、マクロが抜けるという現象からしても、私の試した感じでは、どうやらメモリリークの現象に似ています。アンタッチャブルな部分に触れると、マクロは急停止してしまいます。

なお、Select Case  [値]  ←ここの値は、文字列でも数値でも構わないです。ただ、コードを見る限りは、数値になっているようですので、それ自体は問題なかろうと思います。

ボタンは、フォームオブジェクトのボタンをお使いになっているものだとは思いますが、ActiveX ですと、そのコードですと、少し問題が出る可能性はあります。

それで、私なりの書き方でコードを書いてみましたので、そちらで診ていただけませんか?

'// 基本的には、標準モジュールです。
Sub Integrated_Taxes()
 Dim i As Long '入力表シートの行数
 Dim h As Long 'データ集積シートの最終行
 Dim j As Long '新しく加えた変数
 Dim acSh As Worksheet '現在の表
 Dim iTaxSh As Worksheet
 '***設定****
 Set acSh = ActiveSheet 'このシートは「入力表_税制」か?
 Set iTaxSh = Worksheets("集積_税制")
 
 Application.ScreenUpdating = False
 h = iTaxSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
 With acSh
  For i = 3 To 25 '入力表の入力可能行数
   If .Cells(i, 3).Value > 0 And .Cells(i, 3).Value < 4 Then
    j = .Cells(i, 3).Value + 3
    iTaxSh.Cells(h, 1).Resize(, 3).Value = .Cells(i, 7).Resize(, 3).Value
    iTaxSh.Cells(h, j).Value = .Cells(i, 10).Value
    h = h + 1
   End If
  Next i
 
 End With
 Application.ScreenUpdating = True
 
 iTaxSh.Select
 MsgBox "取り込みが終了しました!"
 Worksheets("入力表_税制").Select
 Range("B1").Select

End Sub
'//

以上です。

#2の回答者です。
長文でまとまっていませんが、私の考えたレポートです。

こちらは、Excel 2013ですが、一応、通して動かしてみて完結はするのですが、途中、何か良くわからない動きがあります。このコードには、どちらかというと「気になる」の部分はあります。しかし、それ以上に、ハングしたかなって思わせるような状態で、マクロが終了しているのです。それが何か今のところは分かりません。
どうも、ステップで進める分には、まったくその問題はみられません。

そのコードで問題になる部分は、2つですが...続きを読む


人気Q&Aランキング

おすすめ情報