ID登録せずに、無料で質問できる♪ 教えて!gooアプリ>>

こんにちは。

VBAで特定のデータを取り出したいのですが、
作業としては
1.アクティブシートをコピーし新しいシートの名前を"補充治具費"にする。
2.AD列が治具費かつAB列に入力されているものが "J" "JB" "JD" "W" 
 で始まっていなければ行ごと削除する。("J" "JB" "JD" "W"の4種類だけ残す)
3.2を一番下の行まで繰り返す

大きく3つですが、AB列にはJBとJBNで始まるものがあり,必要なのはJBだけです。

よろしくお願いします。

A 回答 (2件)

一応、こちらについても回答させていただきます。


何度かこの似た質問が出ていたようですが、これについては、プロセスそのものは回答者にお任せになってください。
しかし、どうも正確なロジックが読みきれません。

"J" "JB" "JD" "W" 
ワイルドカード式ではなくて、
AB列
JB でなおかつJBNではない、JD または、W

AD列は、
JB か JD または、W

ということではありませんか?そもそも、Jで始まる条件というものはなさそうです。

この意味が分かるでしょうか?
=SUMPRODUCT((LEFT(AB2,2)={"JB";"JD"})*(LEFT(AB2,3)<>"JBN")+(LEFT(AB2,1)="W"))
+SUMPRODUCT((LEFT(AD2,2)={"JB";"JD"})+(LEFT(AD2,1)="W"))

AB列は、JB, JD であるが、JBNではない。または、W
AD列は、JB, JD または、W

というクライテリアで出来ています。
数式さえ分かれば、ご自分でも、調整できるはずです。
また、補充治具費の部分は、シートがすでにある場合は、新しいシートに変わります。

'//標準モジュール
Sub PicupDATA()
Dim AcSh As Worksheet
Dim NewSh As Worksheet
Dim Rng As Range
Dim CriteArea As Range
Const FML As String = "=SUMPRODUCT((LEFT(AB2,2)={""JB"";""JD""})*(LEFT(AB2,3)<>""JBN"")+(LEFT(AB2,1)=""W""))+SUMPRODUCT((LEFT(AD2,2)={""JB"";""JD""})+(LEFT(AD2,1)=""W""))>0"
Set AcSh = ActiveSheet
Set NewSh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
On Error Resume Next
NewSh.Name = "補充治具費"
On Error GoTo 0
With AcSh
 If .FilterMode Then
 .ShowAllData
 End If
 Set Rng = .Range("A1").CurrentRegion
 Set CriteArea = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(2)
 CriteArea.Cells(2, 1).FormulaLocal = FML
 Rng.AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=CriteArea, _
       CopytoRange:=NewSh.Range("A1"), _
       Unique:=False
End With
 NewSh.Activate
End Sub
    • good
    • 0

> "J" "JB" "JD" "W" で始まっていなければ



という事ですが、"J" と "W" で始まっているものはすべて残す、という意味でしょうか?

> JBとJBNで始まるものがあり,必要なのはJBだけ

"JB" で始まっているものを残せば、"JBN" も必ず残りますが…?

その辺りについて、もう少し詳しく教えて頂きたいと思います。
    • good
    • 0

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

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

Qvba 自動番号振り

A列に会社の番号B列に会社名。
C列の該当する会社の行に1を入力します(複数あり)
入力と同時にD列に番号を表示。

例1)
1行名はタイトル行
A2=1 B2 〇〇 C2="" D2=""
A3=5 B3 ××  C3=1 D3=002-5-2
A4=5 B4 ×× C4=1 D4=002-5-2

※D3,D4の番号について→002は固定です。5は会社の番号のA列から。2は行カウントの数字ですが、一番上にある行カウントを以下の1が入力された行に自動表示。

次に、例1)で入力したC3とC4の1は削除して、次にC2、C5、C6に1を入力します。
この時に、例1)で表示されたD列の番号はそのまま表示されてほしいです。

A2=1 B2 〇〇 C2=1 D2=002-1-1
A3=5 B3 ××  C3="" D3=002-5-2
A4=5 B4 ×× C4="" D4=002-5-2
A5=1 B5 〇〇 C5=1 D2=002-1-1
A6=1 B6 〇〇 C6=1 D3=002-1-1
A7=5 B7 ×× C7="" D4=""


複雑なのですが、vbaで上記の内容を実現することは可能でしょうか。
可能でしたら教えてくださいませ。
宜しくお願いいたします。

A列に会社の番号B列に会社名。
C列の該当する会社の行に1を入力します(複数あり)
入力と同時にD列に番号を表示。

例1)
1行名はタイトル行
A2=1 B2 〇〇 C2="" D2=""
A3=5 B3 ××  C3=1 D3=002-5-2
A4=5 B4 ×× C4=1 D4=002-5-2

※D3,D4の番号について→002は固定です。5は会社の番号のA列から。2は行カウントの数字ですが、一番上にある行カウントを以下の1が入力された行に自動表示。

次に、例1)で入力したC3とC4の1は削除して、次にC2、C5、C6に1を入力します。
この時に...続きを読む

Aベストアンサー

補足有難うございます.

内容を読むとマクロは少なくとも2つ用意した方が良さそうですね.
①Dのセルに出力するマクロ
②Cのセルを判定するマクロ

考え方から説明しますと
・①はCのセルに値が入力された際に実行する.
・入力されたセルの行の位置を引数に入れる.
(例えばC3セルに入力したなら引数は3,C5セルに入力したなら引数は5)
・上記引数とCellsを利用してD列に値を出力する.

・②はEのセルにが入力された際に実行する.
・入力されたセルの行の位置を引数に入れる.
・上記引数とCellsを利用してCのセルの値を消す.

次に確認ですが,行カウントについて同じグループというのは例えば質問文で考えるとA2,A5,A6は1で,A3,Aは5で,それぞれ同じグループという意味で良いですか.
上記の内容が正しいならこのシートでは上から順に新規で入力された値に対して順々に数値を振り分けているという事になります.
すなわち
・会社番号が1→行カウントで1
・会社番号が5→行カウントで2
例えばA8に会社番号が6というのが入力された場合には行カウントは3になりますか?

ここでの確認の意図は行カウントが上記内容で決定しているとするなら1つ作業列もしくは作業用シートを用意した方が良いと考えるためです.
この作業というのは先ずA列の値で重複する値を削除したものをコピーし,上から1,2,3と番号振り(行カウントの値を決める)を実行するというものです.

具体的には作業シートをSheet2に置くなら,A列の範囲で重複データを削除したものをシート2のA列にコピーすれば
Sheet2のA1が1,A2が5になります.
Dのセルの行カウントの値を出力する時はSheet1のAのセル値を検索値にSheet2のAのセル値と合致するセルの行番号として出力すれば良いという事になります.
(つまり会社番号と行カウントを整理するマクロが別に必要)

まだマクロを組んでテストをしていないので,実際のマクロの記述は回答できていませんが,ご参考までに

あともう一つ確認ですが,質問者さんの立場でこのシートで入力するのはA~C列とE列ですよね?
もしC列も自動化する場合にはE列に1が入力されているかどうかでC列の1の入力/削除も可能です.

補足有難うございます.

内容を読むとマクロは少なくとも2つ用意した方が良さそうですね.
①Dのセルに出力するマクロ
②Cのセルを判定するマクロ

考え方から説明しますと
・①はCのセルに値が入力された際に実行する.
・入力されたセルの行の位置を引数に入れる.
(例えばC3セルに入力したなら引数は3,C5セルに入力したなら引数は5)
・上記引数とCellsを利用してD列に値を出力する.

・②はEのセルにが入力された際に実行する.
・入力されたセルの行の位置を引数に入れる.
・上記引数とCellsを利用してCのセ...続きを読む

QエクセルVBA範囲の取り方

下の表のC1~C9の範囲を取りたいのですが
アクティブをA1にして、列の位置は任意なので
上は、Range("A1").End(xlToRight)になるのかな?
下は、Range("C1048576").End(xlUp)みたいな感じで作るのだろうとは想像するのですが
合わせるにはどうすればいいのかよくわかりません

Aベストアンサー

ふつうなら、
Set rng = Range("C1", Cells(Rows.Count, "C").End(xlUp))
ですよね。

A1セルに対して取るとすれば、このようなコードになります。

 Dim col As Long
 Dim Rng As Range
 col = Cells(1, Columns.Count).End(xlToLeft).Column
 Set Rng = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
 Rng.Select

ただし、C1があるという前提です。

それがない場合は、
col = Range("A1").SpecialCells(xlCellTypeLastCell).Column
Set Rng = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
Rng.Select

こうすることもありますが、SpecialCellsメソッドが失敗することがあります。
ですから、データのパターンによって、いろいろ使い分けた方がよいでしよう。

ふつうなら、
Set rng = Range("C1", Cells(Rows.Count, "C").End(xlUp))
ですよね。

A1セルに対して取るとすれば、このようなコードになります。

 Dim col As Long
 Dim Rng As Range
 col = Cells(1, Columns.Count).End(xlToLeft).Column
 Set Rng = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
 Rng.Select

ただし、C1があるという前提です。

それがない場合は、
col = Range("A1").SpecialCells(xlCellTypeLastCell).Column
Set Rng = Range(Cells(1, col), Cells(Rows.Count, col).En...続きを読む

QExcel VBA 複数シートを別ファイルにコピーして保存

Excel VBAはまだ初心者なので、よくわかっていないのですが、複数シートを別ファイルにコピーして保存したいと思っております。

下記は、一番左のシートだけをB1に書かれ値で別ファイルとして保存できるようなものをつくってみました。ここから、左から1番目と2番目だけをコピーして、同じようにファイル名を指定して保存したいと考えていますが、全くうまくいかず・・・。

お手数ですが、どこを修正すべきなのかをおしえていただけますでしょうか。

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

Sub SheetSave()

Dim xSheet As Worksheet
Dim myFile As String
Dim myName As String

Set xSheet = ActiveSheet

'一番左のファイルのコピー
ThisWorkbook.Worksheets(1).Copy after:=ThisWorkbook.Worksheets(1)

myFile = ThisWorkbook.Path & "\" & xSheet.Range("B1").Value & ".xlsx"
Application.DisplayAlerts = False
ActiveSheet.SaveAs fileName:=myFile
Application.Dialogs(xlDialogSaveAs).Show
Application.DisplayAlerts = True
ActiveWorkbook.Close

End Sub

Excel VBAはまだ初心者なので、よくわかっていないのですが、複数シートを別ファイルにコピーして保存したいと思っております。

下記は、一番左のシートだけをB1に書かれ値で別ファイルとして保存できるようなものをつくってみました。ここから、左から1番目と2番目だけをコピーして、同じようにファイル名を指定して保存したいと考えていますが、全くうまくいかず・・・。

お手数ですが、どこを修正すべきなのかをおしえていただけますでしょうか。

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

Sub SheetSave()

...続きを読む

Aベストアンサー

シート2枚まとめて1つのブックにコピーということなら

Sub SheetSave2()
  Const N As Long = 2
  Dim myFile As String
  Dim myName As String
  Dim mySh(1 To N) As String
  Dim i As Integer

  myFile = ThisWorkbook.Path & "\" & ActiveSheet.Range("B1").Value & ".xlsx"

  '左から N番目までのシートをコピー
  For i = 1 To N
    mySh(i) = Sheets(i).Name
  Next
  Sheets(mySh).Copy

  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs Filename:=myFile
  Application.DisplayAlerts = True
  ActiveWorkbook.Close
End Sub

シート2枚まとめて1つのブックにコピーということなら

Sub SheetSave2()
  Const N As Long = 2
  Dim myFile As String
  Dim myName As String
  Dim mySh(1 To N) As String
  Dim i As Integer

  myFile = ThisWorkbook.Path & "\" & ActiveSheet.Range("B1").Value & ".xlsx"

  '左から N番目までのシートをコピー
  For i = 1 To N
    mySh(i) = Sheets(i).Name
  Next
  Sheets(mySh).Copy

  Application.DisplayAlerts = False
  ActiveWorkbook.Sav...続きを読む

Qエクセルでまたまた困ってます。教えてください(?_?)

Sheet1とSheet2があります。
Sheet1にはA1にコーラ、A2にコーヒー、A3に牛乳と入力しています。
A4には仕入れ先、B4には販売先、C4には製品と項目を作り、C3からD3、E3と日付を入力(1/1から1/3)。
A5~A7までセルを結合し店1と入力、A8~A10までセルを結合し店2と入力。
B5にA店、B6にB店、B7にC店、B8にもA店、B9にB店、B10にC店と入力します。
C5~C10まではデータの入力規制で$A$1:$A$3とします。
Sheet2にはA3とA8を結合しコーラ、A9~A14を結合しコーヒー、A15~A20を結合し牛乳と入力。
B3に仕入れ先B4に販売先、これを交互にB20まで入力。
C2からD2、E2は日付を入力(1/1から1/3)
これで、例えばSheet1のC5でコーラを選択した場合にSheet2の日付、販売先、仕入れ先に反映させたい場合どうしたらよいでしょうか?

Aベストアンサー

入力セルはsheet1のC5~C10なのですね?
sheet1のC5にコーラと入れた場合、
店1→A店にコーラ。というのは分かりますが、日付はどこで指定するのですか?

Qマクロの実行途中で「応答なし」が発生する その2

https://oshiete.goo.ne.jp/qa/9742741.html

の続きでございます。PCを初期化したら、教えてgooのIDとパスワードが不明になり、新しい名前で登場させて頂いております。(汗)

>C:\Windows\System32\Speech\Common\sapi.dll 2016/07/16 PM 5:25 Ver. 5.3.19915.00
確認しました。

現状は
C:\Windows\System32\Speech\Common\sapi.dll 2017/03/19 5:57 Ver. 5.3.20717.00
に変更されています。


>Const SPD As Long = 100 '通常50~200まで ★
>この数字を増やしてみるというのはいかがでしょうか。
残念ながら効果がないです。


>私の方は、Windows 10 にアップグレードした後に、PCが立ち上がらなくなり、OSの再インストールしたお陰で、この音声周りは、半年以上にもなるのに、まだ復旧していません。

Windows 10でちゃんと動いていたのですが、最近、Windows 10マイナーアップデートがあり、以降、「応答なし」が発生するようになりました。


>なお、前回、話は中途だった気がします。あまり細かなリクエストまでは到底背負いきれなかったからです。

私のこのプログラムの使い方は変わってきております。最初は単語だけで使用してました。その語、文で覚える方が効率的であることに気が付きました。そこで
DUO3.0→ALL IN ONE→日経サイエンスの記事

現在、英語で読む日経サイエンスの記事をsheet2に張り付けて使用していますが、下記のように長い文の場合、途中で「応答なし」が発生して一時的に消えます。



Eyeing a stranger, one of more than three million daily passengers on the Tube, he idly wondered:
What is the probability the stranger would emerge at, say, Wimbledon? How could you ever figure that out,
given that the person could take any number of routes


その車内で見知らぬ1人の乗客(ロンドン地下鉄は1日に300万人以上が利用する)を見ながら,ふと思った。
彼が,例えばウィンブルドン駅に現れる確率はどれくらいだろう? 何回乗り換えてもよいとした場合,
その確率はどうすれば計算できるだろう?

http://www.nikkei-science.com/?p=24349
より抜粋しました。


質問とは関係ないですが、日経サイエンスの記事は面白いです。いろんな可能性を考えるのがサイエンスですが、数学的に可能性があっても、
そんな研究をやって本当に役に立つのか?その研究は本当に正しい方向に向かっているのか?と思うものもあります。
上の記事は、ファインマンの方法に関する研究なので、成功したら、役に立つだろうと思います。

https://oshiete.goo.ne.jp/qa/9742741.html

の続きでございます。PCを初期化したら、教えてgooのIDとパスワードが不明になり、新しい名前で登場させて頂いております。(汗)

>C:\Windows\System32\Speech\Common\sapi.dll 2016/07/16 PM 5:25 Ver. 5.3.19915.00
確認しました。

現状は
C:\Windows\System32\Speech\Common\sapi.dll 2017/03/19 5:57 Ver. 5.3.20717.00
に変更されています。


>Const SPD As Long = 100 '通常50~200まで ★
>この数字を増やしてみるというのはいかがでしょ...続きを読む

Aベストアンサー

#1の回答者です。

>最初の行は、文字数200でも「応答なし」は発生しないのですが、途中の行から>文字数135以上になると「応答なし」が必ず発生するようになりました。
>「応答なし」は英文の文字数に関係するかもしれません。

その対処の仕方は二つほど、頭に描いてはいるのですが、実験を繰り返さないと、はっきりとしたことは言えません。暴走を止めるプログラムは、一応、今の現状がはっきりするまでは、そのままにしておいてください。特に、現段階では意味がありません。

足止めするつもりはありませんが、しばらく時間をください。

DUO3.0 は、リスニングにはちょっと厳しい内容です。今のノーマルモードでは少しスピードが速すぎます。

>日経サイエンスの記事は面白いです。
同感です。長い間適当な教材はないかと思っていました。英検準一級以上やIELTS(アカデミック)の教材にふさわしい内容です。それに、この記事を自動ダウンロードするプログラムも面白いと思います。

>英語で読む日経サイエンスの記事をsheet2に張り付けて使用していますが、下記のように長い文の場合・・・・

それならなおさらです。
https://www.naturalreaders.com/

https://www.naturalreaders.com/download.html
Free のアプリがあります。
読ませてみてください。

それで、現状のMSスピークエンジンでは、音が汚いなって思います。逆にいうと、それほど、AT&Tの音声は20年も前でも、それでも今のものよりも上なのですから、
そうとうに優れていたということになりそうです。Win10で動くのか分かりませんが、今、いくら探しても、前のもののディスクが見つかりませんし、もう20年近く前のものですから、新しく新調しようかなって考えています。

Naturalreader のサイトで聞くよりも、本物は遥かに音はクリアで、human voiceらしいです。ロボット音声には聞こえません。昔、Misakiさんいうのがあったのですが、時々関西弁が混じりこみました。いくつかの音声エンジンの会社があります。今のものは、もっと優れています。

#1の回答者です。

>最初の行は、文字数200でも「応答なし」は発生しないのですが、途中の行から>文字数135以上になると「応答なし」が必ず発生するようになりました。
>「応答なし」は英文の文字数に関係するかもしれません。

その対処の仕方は二つほど、頭に描いてはいるのですが、実験を繰り返さないと、はっきりとしたことは言えません。暴走を止めるプログラムは、一応、今の現状がはっきりするまでは、そのままにしておいてください。特に、現段階では意味がありません。

足止めするつもりはありませんが...続きを読む

QVBAでファイルパスが長すぎてコピー時のエラー対策

フォルダ内にあるファイル(xlsx)を1つのファイルごとに分類したいため、
そのファイル名と同名のフォルダを元のフォルダ内に新たに作成し、そこに保存したいという
下記のマクロを見つけて動かしてみたのですが、

FileCopy FPath & "\" & TargetFile, FPath & "\" & DName  & "\" & TargetFile
の箇所でファイルが存在しないと出ました。

色々と調べた結果、サーバーの中にあるファイルを作ろうとしているのですが
サーバーの階層が深く取得するパス名が300文字になっていたので
Dir関数だとエラーになることが判明し、対策として
ショートパスへ変換する方法やFSOを使って行えば解決するという所までは
調べたのですが、上手くいきません。

分かる方がいればアドバイスを頂ければと思い質問をさせて頂きました。
宜しくお願い致します。




Sub フォルダ作成()
  Dim FPath, TargetFile, DName

  FPath = Range("A1").Value
'セルのA1にサーバーのパスを記載しています

\\TEST\TESTファイル\管理項目\管理簿\各担当部署\確認事項\
上記の記載は例ですが本来の記載はかなり長く、260文字くらいあります。

  If FPath = "" Then Exit Sub
  TargetFile = Dir$(FPath & "\*.xlsx")
  Do While TargetFile <> ""
   DName = Left(TargetFile, InStrRev(TargetFile, ".") - 1)

   MkDir FPath & "\" & DName
ファイル名と同名のフォルダをサーバーに作成するのは成功しています。

   FileCopy FPath & "\" & TargetFile, FPath & "\" & DName _
      & "\" & TargetFile
上記の部分でエラーが出ており、パス名が長いためエラーになっています。


   Kill FPath & "\" & TargetFile
   TargetFile = Dir$
  Loop

 End Sub


Dim fso As New FileSystemObject
ファイルオブジェクトを使い、ショートパスにすればという
所までは調べたのですが、そこからどう繋げていいか不明なので
お手数ですがご教授願えないでしょうか?

フォルダ内にあるファイル(xlsx)を1つのファイルごとに分類したいため、
そのファイル名と同名のフォルダを元のフォルダ内に新たに作成し、そこに保存したいという
下記のマクロを見つけて動かしてみたのですが、

FileCopy FPath & "\" & TargetFile, FPath & "\" & DName  & "\" & TargetFile
の箇所でファイルが存在しないと出ました。

色々と調べた結果、サーバーの中にあるファイルを作ろうとしているのですが
サーバーの階層が深く取得するパス名が300文字になっていたので
Dir関数だとエラー...続きを読む

Aベストアンサー

このご質問の回答としては、私は、以下のコードを提示しますが、何か別の方法があったような気がしてなりません。

Function shortName(ByVal FileName As String)
'ショートネイム用のユーザー定義関数
 Dim objFS As Object
 Dim objFile As Object
 Set objFS = CreateObject("Scripting.FileSystemObject")
 If Right(FileName, 1) <> "\" Then 'フォルダーとファイルの区分け
  Set objFile = objFS.GetFile(FileName)
 Else
  Set objFile = objFS.GetFolder(FileName)
 End If
 shortName = objFile.shortPath
End Function

使用例:
Sub TestLongFileName()
 Dim fn As String

 Dim dst As String
 fn = "---long Name file ----"
 fn = shortName(fn)
 If Dir(fn) = "" Then
  MsgBox "ファイルが見つかりません", vbCritical
  Exit Sub
 End If

 dst = ""---long Name Path ----"" '末尾に¥を入れないとエラーが出ます。
 dst = shortName(dst)
FileCopy fn, dst
' ' Shell ("cmd.exe /c Copy " & fn & " " & dst)
End Sub

このご質問の回答としては、私は、以下のコードを提示しますが、何か別の方法があったような気がしてなりません。

Function shortName(ByVal FileName As String)
'ショートネイム用のユーザー定義関数
 Dim objFS As Object
 Dim objFile As Object
 Set objFS = CreateObject("Scripting.FileSystemObject")
 If Right(FileName, 1) <> "\" Then 'フォルダーとファイルの区分け
  Set objFile = objFS.GetFile(FileName)
 Else
  Set objFile = objFS.GetFolder(FileName)
 End If
 shortName = ob...続きを読む

Q複数のexcelファイルを一つにするには

formatが全く同じとは言えないが、月報があります。
これを結合して一つのファイルにしようと思っています。
一件ずつを呼び出し、コピーする方法しか思い浮かびません。
それでは年報に直すのに、同じことを12回する必要あります。
列幅や列数が異なる場合があるかも知れません。
その場合は一旦結合した後、個別に修正しようと思っています。
良い方法ありませんか。

Aベストアンサー

何度実行しても良いようになっていますのでもう一度最初から実行してみてください。
ちなみに、マクロを入れたファイルは開始時と終了時に毎回消去しているので何も表示されないはずです。出来上がった「友の会・観察会資料2017.xlsx」はどうなっていますか?

まさかとは思いますが、このマクロを記録したファイルの名前は「友の会・観察会資料2017.xlsx」や「友の会・1月観察会資料2017.xlsx」などにはしていませんよね?

多分間違いだと思うので勝手に直しましたが、もちろん「友の会・1月観察会資料2014.xclx」などは「友の会・1月観察会資料2014.xlsx」などの間違いですよね?

Qexcel vbaで日付指定で入力

■問合せの内容
会社で毎日の営業の獲得成績をエクセルにフォームで入力出来る様にしたいのですかうまくできません。

フォームのテキストボックス1に日付
以下テキストボックスに獲得数字を入力し登録ボタンを押すとテキストボックスの日付をA列から探し一致した日にちの列の指定セルに入力していきたいです。

2007年 6月
A列 B列 C列
日付 リンゴ みかん
1日 3 5
2日 5 4
3日
と言った感じです。
入力するのは今月分ですのでフォームで選んだ日付が該当しない場合はエラーを出したいのですが。

宜しくお願い致します

Aベストアンサー

こんにちは!

横からお邪魔します。
VBAの場合、日付検索には注意が必要です。
表示形式によってコード変更が必要になる場合がほとんどだと思います。

質問文通りA列の日付はシリアル値で表示形式が d日 となっているとします。
該当データがある場合はその行のB列にテキストボックス2のデータを、C列にテキストボックス3のデータを入力するというコードです。

Private Sub CommandButton1_Click()
Dim c As Range
Set c = Range("A:A").Find(what:=Format(TextBox1, "d日"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c.Offset(, 1) = TextBox2.Value
c.Offset(, 2) = TextBox3.Value
TextBox1 = ""
TextBox2 = ""
TextBox3 = ""
TextBox1.SetFocus
Else
MsgBox "該当日付なし"
End If
End Sub

※ A列の表示形式によって
>Format(TextBox1, "d日")
の部分で調整してみてください。

※ 表示形式だけでは「年・月」の判別ができませんので
今年・今月以外のデータでも「該当日付」はある!と判断してしまいます。

以上のコトを考慮すればA列の日付は最低限 7/3 のような感じにしておけば
少なくとも「月」の判断だけは可能です。m(_ _)m

こんにちは!

横からお邪魔します。
VBAの場合、日付検索には注意が必要です。
表示形式によってコード変更が必要になる場合がほとんどだと思います。

質問文通りA列の日付はシリアル値で表示形式が d日 となっているとします。
該当データがある場合はその行のB列にテキストボックス2のデータを、C列にテキストボックス3のデータを入力するというコードです。

Private Sub CommandButton1_Click()
Dim c As Range
Set c = Range("A:A").Find(what:=Format(TextBox1, "d日"), LookIn:=xlValues, ...続きを読む

QVBAで、Functionを、クラスモジュールに置くか? 標準モジュールに置くか? 使い勝手は?

*.jpgファイルの撮影日時を、自作プログラムに読み込む必要に迫られ、いろいろお尋ねしました。
その結論は、ユーザー定義関数を自作して利用する、でした。
その時ご紹介頂いたのが、WEB公開のJpegExifクラスのCodeの利用でした。
その際、もっと端的に、システム内臓の、ADODB.Streamや、WIA.ImageFileを使って、
撮影日時を読み出す方法も教えて頂きました。

今回は、自前のCodeで撮影日時を読み出す事が目標でしたので、現在は、標準モジュールに、
JpegExifクラスの簡易版を置いて、自作プログラムを動かしています。

この際の試行錯誤の過程で、この簡易撮影日時読み出しFunctionを、クラスモジュールに置いたり、
標準モシュールに置いたり、いろいろテストしました。
両方の機能は同じで、使い勝手は標準モジュールに置いた方でした。

規模の大きいシステムで、クラスモジュールを使いこなされている方々にお伺いしたいのですが、
特定のFunctionを、クラスモジュールに置くか標準モジュールに置くかの判断の分岐点は何でしょうか?

*.jpgファイルの撮影日時を、自作プログラムに読み込む必要に迫られ、いろいろお尋ねしました。
その結論は、ユーザー定義関数を自作して利用する、でした。
その時ご紹介頂いたのが、WEB公開のJpegExifクラスのCodeの利用でした。
その際、もっと端的に、システム内臓の、ADODB.Streamや、WIA.ImageFileを使って、
撮影日時を読み出す方法も教えて頂きました。

今回は、自前のCodeで撮影日時を読み出す事が目標でしたので、現在は、標準モジュールに、
JpegExifクラスの簡易版を置いて、自作プログラムを動かしています。

こ...続きを読む

Aベストアンサー

昨日に書いた内容は、間違っていました。申し訳ありません。

『ブック間をまたぐようなものに関しては、その利便性は発揮しますが、……』
実際にこちらでユーザー定義関数を作ってやってみました。実際にやるのは、たぶん、二度目ぐらいで、うっすらと記憶のある程度でした。

私の言葉の説明よりも絵をみていただければよいのですが、
http://yamav102.cocolog-nifty.com/blog/2013/07/vba-friend-inst.html

Class のプロパティのInstancing を 「PublicNotCreateable」にして、相手のブックで、参照設定して、Classから呼び出すと、簡単に説明するとそうなるのですが、

昨日から、いろいろ検証してみたのですが、クラス・オブジェクトは、Public にすれば、Projects 間で簡単に融通が利くと思っていたのです。ところが、これでは、手数が多すぎます。これしかないのなら、やむを得ずおすすめしますが、アドインとして呼び出したほうが楽に扱えます。

ご質問者さんのは、ユーザー定義関数のスタイルですから、クラスを辞めて、標準モジュールに戻した後、ファイルをアドイン型(.xlam)で保存します。そして、アドインで呼び出した方が早いことが分かりました。

>VBAで、Functionを、クラスモジュールに置くか? 標準モジュールに置くか? 
結果としては、標準モジュールの方が良いということになりました。

なお、違うブックで、モジュールを共用して呼び出すなら、アドインにする必要もなく、VBEditor 内の相手のブック側で参照設定をすればよいです。

昨日に書いた内容は、間違っていました。申し訳ありません。

『ブック間をまたぐようなものに関しては、その利便性は発揮しますが、……』
実際にこちらでユーザー定義関数を作ってやってみました。実際にやるのは、たぶん、二度目ぐらいで、うっすらと記憶のある程度でした。

私の言葉の説明よりも絵をみていただければよいのですが、
http://yamav102.cocolog-nifty.com/blog/2013/07/vba-friend-inst.html

Class のプロパティのInstancing を 「PublicNotCreateable」にして、相手のブックで、参照設定して、...続きを読む

Qexcel vba if文入れ子のスマートな記入方法は?

excel vba if文入れ子のスマートな記入方法を教えてください。

下記のような場合、処理Aを2回記入せずにすむ論理式があったら教えていただけないでしょうか?
処理Aが多い場合は、「call 処理A」として別に記入しています。
それでもどうしても2回記入しなくてはならないでしょうか?

【セルE1の値を判定して 数値「100」を入力する式】
Sub test()
Dim mymsg As Integer

If Range("E1") = 0 Or Range("E1") = "" Then
  Range("E1").Value = 100 '処理A
Else
 mymsg = MsgBox("値を消去して新しいデータを挿入します。", vbOKCancel)

 If mymsg = 1 Then
  Range("E1").Value = 100 '処理A
 Else
 ' 何もしない
  End If

End If
End Sub

Aベストアンサー

Exit Subを使って良いのであれば、test1。使えないなら、test2でどうでしょう?

Sub test1()
If Range("E1").Value <> "" And _
Range("E1").Value <> 0 Then
If MsgBox("値を消去して新しいデータを挿入します。", vbOKCancel) = vbCancel Then
Exit Sub
End If
End If
Range("E1").Value = 100 '処理A
End Sub

Sub test2()
Dim mymsg As Integer
mymsg = vbOK
If Range("E1").Value <> "" And _
Range("E1").Value <> 0 Then
mymsg = MsgBox("値を消去して新しいデータを挿入します。", vbOKCancel)
End If
If mymsg = vbOK Then
Range("E1").Value = 100 '処理A
End If
End Sub

Exit Subを使って良いのであれば、test1。使えないなら、test2でどうでしょう?

Sub test1()
If Range("E1").Value <> "" And _
Range("E1").Value <> 0 Then
If MsgBox("値を消去して新しいデータを挿入します。", vbOKCancel) = vbCancel Then
Exit Sub
End If
End If
Range("E1").Value = 100 '処理A
End Sub

Sub test2()
Dim mymsg As Integer
mymsg = vbOK
If Range("E1").Value <> "" And _
Range("E1").Value <> 0 Then
my...続きを読む


人気Q&Aランキング