在宅ワークのリアルをベテランとビギナーにインタビュー>>

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range)で、
セルA1をダブルクリックすると、プロシージャMacro1へとび、Macro1で所定の処理を行ったあと、もとのPrivate Sub Worksh
eet_BeforeDoubleClick(ByVal Target As Range)にもどします。

①Macro1で処理をしたあと、冒頭のPrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range)に戻せない。

②Macro1の処理を終えないと、B1やC1のダブルクリックをしても無効としたい。

どのようにプログラムすれば宜しいでしょうか?

現状

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range)

Select Case Target.Address(False, False)

If Target.Address<>"A1"
Call Macro1
End If

If Target.Address<>"B1"←Macro1の処理が終わらないとダブルクリック無効としたい。
Call Macro2
End If

If Target.Address<>"C1"←Macro1の処理が終わらないとダブルクリック無効としたい。
Call Macro3
End If

EndSub
------------------------------------------------------------
Private Sub Macro1

MsgBox"AAA"←実際は別の処理。

Call ←冒頭のPrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range) に戻したい。

この時、Callのあとはどのように記述すべきでしょうか?

そのまま、Call Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range) としても、Private Sub Worksheet_BeforeDoubleClick()としても、うまくいきません。

A 回答 (2件)

こんばんは。


なるべく単純に、ご質問を写してみました。
ただ、
If Target.Address<>"C1"
この部分は、適宜、変えてください。
もし、コードの一覧性が悪いのでしたら、Call されるマクロはシートモジュールでも構いません。myFlg をグローバル・スコープ変数やシート・スコープ変数にすればいいと思います。

'標準モジュール
Public myFlg As Variant

Sub Macro1()
 MsgBox "Execute Macro1"
End Sub
'--------
Sub Macro2()
 MsgBox "Execute Macro2"
End Sub
'--------
Sub Macro3()
 MsgBox "Execute Macro3"
End Sub

'シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 Cancel = True
 If myFlg = False Then
  If Target.Address(0, 0) = "A1" Then
   Call Macro1
   myFlg = True
  End If
 Else
  If Target.Address(0, 0) = "B1" Then
   Call Macro2
  ElseIf Target.Address(0, 0) = "C1" Then
   Call Macro3
  End If
 End If
End Sub
    • good
    • 0

こんばんは!



どこか使っていないセルを使用し、フラグを立てる方法はどうでしょうか?

仮にZ1セルを利用する場合、
A1セルをダブルクリック → Macro1 の処理が終わった時点でZ1セルを「TRUE」とする。
B1・C1セルのダブルクリックはZ1セルが「TRUE」の場合のみ実行!
Macro2・Macro3を実行後のZ1セルは「FALSE」にする!

といった感じです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("A1:C1")) Is Nothing Then Exit Sub
Cancel = True
Select Case Target.Address(False, False)
Case "A1"
Call Macro1
Case "B1"
If Range("Z1") = True Then
Call Macro2
End If
Case Else
If Range("Z1") = True Then
Call Macro3
End If
End Select
End Sub

Private Sub Macro1()
'//Macro1の処理//
Range("Z1") = True
End Sub

Private Sub Macro2()
If Range("Z1") = True Then
'//Macro2の処理//
Range("Z1") = False
End If
End Sub

Private Sub Macro3()
If Range("Z1") = True Then
'//Macro3の処理//
Range("Z1") = False
End If
End Sub

こんな感じではどうでしょうか?m(_ _)m
    • good
    • 0
この回答へのお礼

目から鱗です。
Excelだからできる技ですね。
セルに値を入れるなんて発想は
無かったです。
ありがとうございます!

お礼日時:2017/08/27 22:07

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

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

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

QVBAで名前検索と可視セル数値の別シート貼り付け

VBAに詳しい方、たすけてください。
Excel2010のVBAで下記のように動くプログラムを組んではいただけないでしょうか。

①ExcelのBook全体のD列をユーザーが入力した任意の文字で検索する(テ

キストボックスを表示する)
②検索結果の文字の1個下の行に入った数値の合計を、検索した時に入力した文字数と一緒に「計算結果」というシートに貼り付ける。
例:検索した名前が「たまねぎ」で、その名前がsheet1のD3にあったら4行目の可視セルに入った数値の合計と名前をシート「計算結果」に貼り付ける。

※sheet2のD7にも同名の「たまねぎ」があった場合、8行目の可視セルの合計を加算して、総計を返す。返す値はブック全体の名前検索結果の1つ下の行の可視セルの合計。

シート「計算結果」
A1 B1
たまねぎ 合計(全シートのD列にたまねぎが入った行の、
1つ下の行の可視セルの合計)
貼り付けの際、A1とB1に既に別の文字と数値が入っていた際は
次の空白の行A2とB2に貼り付ける(空白のセルに貼り付ける)

VBAに詳しい方、たすけてください。
Excel2010のVBAで下記のように動くプログラムを組んではいただけないでしょうか。

①ExcelのBook全体のD列をユーザーが入力した任意の文字で検索する(テ

キストボックスを表示する)
②検索結果の文字の1個下の行に入った数値の合計を、検索した時に入力した文字数と一緒に「計算結果」というシートに貼り付ける。
例:検索した名前が「たまねぎ」で、その名前がsheet1のD3にあったら4行目の可視セルに入った数値の合計と名前をシート「計算結果」に貼り付ける。
...続きを読む

Aベストアンサー

続けてお邪魔します。

結局各シートのD列を検索し、D列に対象品名があればその1行下のK~BT列の数値を合計すれば良いのですね?
↓のコードにしてみてください。

Sub Sample2()
Dim k As Long, myRow As Long, myFlg As Boolean
Dim myStr As String, wS As Worksheet
Dim myRng As Range, myFound As Range, myFirst As Range
myStr = InputBox("検索品名を入力")
With Worksheets("計算結果")
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> .Name Then
Set wS = Worksheets(k)
Set myFound = wS.Range("D:D").Find(what:=myStr, LookIn:=xlValues, lookat:=xlWhole)
If Not myFound Is Nothing Then
.Cells(myRow, "A") = myStr
myFlg = True
Set myFirst = myFound
GoTo 処理
Do
Set myFound = wS.Range("D:D").FindNext(after:=myFound)
If myFound.Address = myFirst.Address Then Exit Do
GoTo 処理
処理:
Set myRng = Range(wS.Cells(myFound.Row + 1, "K"), wS.Cells(myFound.Row + 1, "BT"))
With .Cells(myRow, "B")
.Value = .Value + WorksheetFunction.Sum(myRng)
End With
Loop
End If
End If
Next k
If myFlg = False Then
MsgBox "該当品目なし"
End If
End With
End Sub

今度はどうでしょうか?m(_ _)m

続けてお邪魔します。

結局各シートのD列を検索し、D列に対象品名があればその1行下のK~BT列の数値を合計すれば良いのですね?
↓のコードにしてみてください。

Sub Sample2()
Dim k As Long, myRow As Long, myFlg As Boolean
Dim myStr As String, wS As Worksheet
Dim myRng As Range, myFound As Range, myFirst As Range
myStr = InputBox("検索品名を入力")
With Worksheets("計算結果")
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
For k =...続きを読む

QExcelVBAを武器に就活

こんにちは

私は現在25歳のフリーターです。
来年度就活する予定なのですが、その就活のためにExcelVBAを勉強中です。

そこで質問があります。
ExcelVBAを使ったお仕事に就きたいと考えているのですが、
ExcelVBAを独学である程度使える人を募集する会社などはあるのでしょうか?

先ほど自分で探してみた結果、ExcelVBAの経験者のみや、他の言語も併せて使える人(JavaだったりAccsessVBAだったり)と募集要項にありました。

プログラマになりたいわけではないのですが(できればExcelVBAを使いばりばりマクロなどを書いていきたいです)、主にExcelを使った仕事に就きたいと考えた場合、ExcelVBAだけをある程度使えるというのはやはり就活の武器としては弱いのでしょうか?

ご回答いただけるとありがたいです

Aベストアンサー

返事ありがとうございます。
#4で挙げた人は、30歳でVBAの世界でデビュー?だったかな。
でも、この人は、VBAが好きだったのだろうと思います。
やはり最終的には、数学の出来・不出来が影響しているような気がしてなりません。

プロレベルのVBAの世界に入り込めた人は、正直なところ羨ましいです。
本人の努力もありますが、ラッキーな部分もあるからです。
時代の波に乗ることは大事なことかもしれません。

25歳ぐらいだったら、どこでも潜り込めると思います。
まだ、若い方だから言えるのは、資格の三種の神器を心がけてください。
PC系、語学系、ビジネス系 (例:MOS, TOEIC, 簿記)

>契約社員だったら実務未経験のExcelVBAを使える人募集中というのが結構ありましたし、
逆に、契約社員だから、実務経験なしでも、Excel VBAの使える人を求められるのかと思います。契約社員だから、Excel VBAを作らせて、それが終われば「さようなら」になるのかもしれません。

私が最初にマクロを教わったのは、Excelではありませんが、元派遣で働いていた人からですが、その人は、マクロなんてそんなに必要ないのでした。とにかく、入力が速いし、タフだからです。入力のコツも、その人から教わりました。

その人からみると、マクロのコードを考えるよりも、すぐに打ち込んだ方が完成が速いと教わりました。それでも、私は、入力スピードは、英文1800 和文 670[変換あり] (各10分)の証明書を貰っています。私は、教えてはいませんが、一応、PCのインストラクターです。

マクロひとつで、数人分の仕事をしてくれたり、朝からお昼まで掛かるような面倒な計算さえ、10分の自動実行で印刷まで出来てしまうわけです。マクロなしでは仕事ができない状態になっていました。

その後、私は、単発で働いたりした場合、マクロを作っても、昼ごはんをおごってやればよい、とか考える人や、コーヒー一杯で済むだろうとか、どこからか他人のマクロを持ってきて、会社に合うように作り変えてくれとかいうのですが、お金のことを言ったら、怒り始めました。一番、ひどい話が、記録マクロで1万行を越えてしまったものを、直してくれと持ち込まれた時です。どうか、私のようにはならないでください、としか言えません。

プライベートでマクロやVBAを楽しみながら、表ではOffice のExcel, Word を使えますということで、MOSの資格を履歴に書いておくぐらいで、本来は十分だと思います。

それと、やるやらないは別として、VBAに関係するものは、前回のVSTOを始め、一通り用意しておいても損はないと思います。ですが、VBAが、このまま続くのか、私は疑心暗鬼です。

それと、今の私の参考サイト
http://www.ka-net.org/index.html

Excel情報に明るいおすすめサイト5選
Mougを始め、有名なところです。
http://excel-master.net/miscellaneous-knowledge/excel-recommended-5site/

書籍では、mougの大村あつしさんのVBAの本ををお薦めします。

返事ありがとうございます。
#4で挙げた人は、30歳でVBAの世界でデビュー?だったかな。
でも、この人は、VBAが好きだったのだろうと思います。
やはり最終的には、数学の出来・不出来が影響しているような気がしてなりません。

プロレベルのVBAの世界に入り込めた人は、正直なところ羨ましいです。
本人の努力もありますが、ラッキーな部分もあるからです。
時代の波に乗ることは大事なことかもしれません。

25歳ぐらいだったら、どこでも潜り込めると思います。
まだ、若い方だから言えるのは、資格の三種の神...続きを読む

Qマクロで行挿入

エクセルでマクロを使って18行ごともしくは24行ごとに行を挿入し挿入したセルに「確定商品」の様にコメントを入れてそれをA1からA2、A3・・・と下に向かって行挿入を繰り返したいのですが、
マクロを使えば可能でしょうか?
※コメントは同じものを使います。

宜しくお願い致します。

Aベストアンサー

こんにちは!

>18行ごともしくは24行ごとに行を挿入し・・・

行挿入・行削除等を行う場合、最終行から上に遡って操作するのが間違いが少ない方法です。
データ数がきっちり18や24で割り切れる数であればそのようなことが可能ですが、
そうでない場合はかなり厄介です。

仮にA列のデータ数が18できっちり割り切れる場合のコードは

Sub Sample1()
Dim i As Long
For i = Cells(Rows.Count, "A").End(xlUp).Row - 17 To 1 Step -18
Rows(i).Insert
Cells(i, "A") = "確定商品"
Next i
End Sub

としても大丈夫だと思います。

※ 個人的には別の方法で

Sub Sample2()
Dim i As Long, lastRow As Long, myRng As Range
Set myRng = Range("A1") '//←最初の行を格納しておく//
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row Step 18
Set myRng = Union(myRng, Cells(i, "A"))
Next i
myRng.EntireRow.Insert
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range(Cells(1, "A"), Cells(lastRow, "A")).SpecialCells(xlCellTypeBlanks).Value = "確定商品"
End Sub

のような感じでやる方が良いと思います。m(_ _)m

こんにちは!

>18行ごともしくは24行ごとに行を挿入し・・・

行挿入・行削除等を行う場合、最終行から上に遡って操作するのが間違いが少ない方法です。
データ数がきっちり18や24で割り切れる数であればそのようなことが可能ですが、
そうでない場合はかなり厄介です。

仮にA列のデータ数が18できっちり割り切れる場合のコードは

Sub Sample1()
Dim i As Long
For i = Cells(Rows.Count, "A").End(xlUp).Row - 17 To 1 Step -18
Rows(i).Insert
Cells(i, "A") = "確...続きを読む

QVBA、マクロについて、どなたか知恵をお貸し願います!

VBA独学中の初心者です。
ある問題に躓いており、どうしても動かない部分があるため、皆様のお力添えをいただきたいです。
説明が稚拙で分かりづらいかもしれませんが、宜しくお願いいたします。

① 2つのbook(book1/book2)があるとし、登録したマクロはbook2に設置する。
book2のsheet2に以下のような表を作る。
 ※枠線がズレてしまっていますが、それぞれが1つのセルと考えてください。
  人物・情報と入力されたセルは見出しです。
  また、1人の人物のデータに対し、その人の情報が3つあるとします。
  
______________
|人物   |   情報   |
_______________

|B君 |  |  |  |
_______________
|C君   | | | |
_______________
|A君 | | | |
_______________


② book1のsheet3に、同じ表があるとする。ただし、情報のセルは記入されている。
 
________________
|人物   |   情報     |
_______________

|A君 |長男|中学生|14歳|
_______________
|B君   |次男|小学生|10歳|
_______________
|C君 |長男|高校生|16歳|
_______________

③book2に設置しているマクロを実行すると、book1/sheet3のデータを読み込み、book2/sheet2の該当する人物のデータに表示されるようにする。但し、①②をみてわかるように、人物の名前の順番は同じではない。



・・・というものです。
最初に作ったプログラムでは、以下のように考えました。

book1/sheet3のUsedRangeから”A君”という文字列を

Set A君1 = Cells.Find(what:="A君", lookat:=xlPart)
で探し、
Selection.Offset(Columnoffset:=1).Select
で1つとなりのセルをActiveにし、
そのActivecellを"A君情報1"という変数にし、Do loopを使ってbook1/sheet3の"情報"セルがが空白になるまで1つずつ右に移動/変数を設定し、その値をbook2/sheet2の該当セルに代入していく・・・・(book2/sheet2の表からも、同じ工程で"A君"を探し、隣のセルに変数を設定する)というものです。そして、C君までの情報を全て出力し終えるというプログラムを作りたいのです。

ちなみに、book2からbook1の呼び出しはできました。

以下が作ってみたプログラムです。↓




'型があっていないとエラーになるため、とりあえずすべてVariant型にしています
Dim SorceFile As Variant, OpenFile As Variant
Dim A君1 As Variant, B君1 As Variant, C君1 As Variant
Dim A君情報1 As Variant, B君情報1 As Variant, C君情報1 As Variant
Dim A君情報2 As Variant, B君情報2 As Variant, C君情報2 As Variant

'現在開いているbook2の名前をSorceFileという変数にする
Set SorceFile = ThisWorkbook
'ファイル(book1)を選択して開く
OpenFile = Application.GetOpenFilename
If OpenFile <> fales Then
Filename = Dir(OpenFile)
MsgBox Filename
Workbooks.Open OpenFile
Else
MsgBox "キャンセルされました"
End If

'開いたファイル(book1)から、"A君"という文字列を探す。見つかったら、1つ隣のセルに移動し、"A君情報1"という変数を設定する。
ActiveSheet.UsedRange.Select
Set A君1 = Cells.Find(what:="A君", lookat:=xlPart)
A君1.Select
A君1.Offset(columnoffset:=1).Select
A君情報1 = ActiveCell

'マクロが設置されているbook2をアクティブにし、同様に"A君"という文字列を探す。見つかったら、1つ隣のセル(空白)に移動し、その空白のセルに"A君情報2"という変数を設定する。
ThisWorkbook.Activate
ActiveSheet.UsedRange.Select
Set A君2 = Cells.Find(what:="A君", lookat:=xlPart)
A君2.Select
A君2.Offset(columnoffset:=1).Select
A君情報2 = ActiveCell




・・・と、ここまではステップインをしながら変数の値を確認できています。、
このあとbook2の空白のセル"A君情報2"にbook1の"A君情報1"の値を代入したいのですが、

ThisWorkbook.Worksheets("sheet2").A君情報2.value = Workbooks(SorceFile).Worksheet("sheet1").A君情報1.value

↑ではコンパイルエラーになります。book2の表、A君の空白の情報で"長男"~"14歳"まで、book1から抽出/出力ができたら、次はB君C君・・・としていきたいのですが、「型が一致しない」や「インデックスが有効範囲にありません」となってしまいます。
この値だけ代入することができれば、私の力でもプログラムを最後まで作成することができるのですが・・・

分かりづらく、しかも玄人の方からすれば何だこのマクロは!!となるかもしれませんが、
どうかアドバイスの程、宜しくお願いいたします。

VBA独学中の初心者です。
ある問題に躓いており、どうしても動かない部分があるため、皆様のお力添えをいただきたいです。
説明が稚拙で分かりづらいかもしれませんが、宜しくお願いいたします。

① 2つのbook(book1/book2)があるとし、登録したマクロはbook2に設置する。
book2のsheet2に以下のような表を作る。
 ※枠線がズレてしまっていますが、それぞれが1つのセルと考えてください。
  人物・情報と入力されたセルは見出しです。
  また、1人の人物のデータに対し、その人の情報が3つあると...続きを読む

Aベストアンサー

こんばんは。

要するに、ソースファイル(データファイル)から情報を取り出す内容なのですね。
それをあえてFind メソッド指定なのかな?

>ActiveSheet.UsedRange.Select
だったら、以下は、Cells ではなくて、Selection でしょうね。

> Cells.Find(what:="A君", lookat:=xlPart)
なぜ、xlPart になっているのでしょうか?表記の乱れがあるということでしょうか?
変数の使い方とか、初歩的なところがまだ出来ていません。

>玄人の方からすれば何だこのマクロは
Findメソッド は、常連さんの某氏の専売特許のようなものですが、私だと、配列からMatch関数を利用しいるのだろうとは思います。玄人的なら、ADODBでしょう。ファイルを直接開けないで可能だからです。もちろん、Excel関数での処理もありますが、あまり格好がよくありません。

私が書くと、こんなコードにしてしまいます。

person info1 info2 info3
A君 長男 中学生 14歳
B君 次男 小学生 10歳
C君 長男 高校生 16歳
D君 三男 大学生 18歳 * 新たな情報が加わった場合も、D君のものだけを取るようにしています。

一旦取得した後に、D君の資料を取り寄せる
B君 次男 小学生 10歳
C君 長男 高校生 16歳
A君 長男 中学生 14歳 
D君 



'//標準モジュール
Sub GetDataAll()
 Dim wb1 As Workbook 'データのソースファイル
 Dim AcSh As Worksheet 'アクティブシート(データを受け取る側)
 Dim c As Range
 Dim r As Range
 Dim startRw As Long '検索文字列の最初の行
 Dim FindArea As Range 'データ・ソースの被検索場所
 Const FNAME As String = "myDATABook.xlsx" 'Thisbook と同フォルダーのファイル名
 Set AcSh = ThisWorkbook.Worksheets("Sheet2")
 
 On Error GoTo ErrHandler
 Set wb1 = Workbooks(FNAME) 'オブジェクトとして認識できるか?できなければ、ErrHandlerに飛ぶ
 
 Set FindArea = wb1.Worksheets("Sheet1").Columns(1) 'ソースファイルの1列目を検索
 With AcSh
  Application.Goto AcSh.Range("A1") 'データをインポートするシートに戻る

  'データに空きがないか調べ、データ検索の初期値の行を求める
  If .Cells(Rows.Count, 1).End(xlUp).Row > .Cells(Rows.Count, _
    2).End(xlUp).Row Then
    startRw = .Cells(Rows.Count, 2).End(xlUp).Row + 1
  Else
    MsgBox "データの取得の必要がありません。", vbExclamation
    Exit Sub
  End If
  
  '単語検索は、ワイルドカードを加える, c.Value & "*" ->LookAt:=xlWhole となる
  For Each c In .Range(.Cells(startRw, 1), .Cells(Rows.Count, 1).End(xlUp))
   If c.Value <> "" Then
    Set r = FindArea.Find(What:=c.Value & "*", LookIn:=xlValues, _
      LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
      MatchByte:=False)
    If Not r Is Nothing Then
     '配列の受け渡し(非推奨)
     c.Offset(, 1).Resize(, 3).Value = r.Offset(, 1).Resize(, 3).Value
    End If
   End If
  Next
 End With
 Exit Sub
ErrHandler:
 'エラーの発生の場合
 If Err.Number = 9 Then
  If Dir(FNAME) <> "" Then
   Workbooks.Open FNAME
   Resume 'エラーを発生した所まで戻る
  Else
   MsgBox "ファイルが見つからないか、パスを指定してください。", vbExclamation
   Exit Sub
  End If
 Else
  MsgBox Err.Number & " :" & Err.Description & " :" & Erl
 End If
End Sub

'//

 '配列の受け渡し
 c.Offset(, 1).Resize(, 3).Value = r.Offset(, 1).Resize(, 3).Value

入門・初級レベルでは、Copy メソッドのほうが良いでしょう。
r.Offset(, 1).Resize(, 3).Copy c.Offset(, 1)

こんばんは。

要するに、ソースファイル(データファイル)から情報を取り出す内容なのですね。
それをあえてFind メソッド指定なのかな?

>ActiveSheet.UsedRange.Select
だったら、以下は、Cells ではなくて、Selection でしょうね。

> Cells.Find(what:="A君", lookat:=xlPart)
なぜ、xlPart になっているのでしょうか?表記の乱れがあるということでしょうか?
変数の使い方とか、初歩的なところがまだ出来ていません。

>玄人の方からすれば何だこのマクロは
Findメソッド は、常連さんの某氏の専売特許の...続きを読む

QExcel VBAについて

Excel VBAについての質問です。

現在UserForm1とUserForm2の二つを用意しておりUserForm1にはコマンドボタンが10個、
UserForm2にはリストボックスが一個配置されています。

やりたいことは…
UserForm1のコマンドボタンを押しそのコマンドボタン名をEXCELのSheet1からFind関数を使用して検索し、
その検索結果の列をUserForm2のリストボックスに表示させるといったものを作成していますが
どうしてもコマンドボタンの名前(Caption)を取得することが出来ません。

どのように取得したらよいのでしょうか?

検索イメージは
.Range("A1:V1").Find("CommandButton.name").Column
こんな感じでしょうか?


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

Aベストアンサー

コマンドボタンのオブジェクト名がCommandButton1なら
CommandButton1.Caption
で取得できます。

QVBAか関数でできるのでしょうか?

いつもこちらで皆さんに助けていただいてます。昨日質問しましたが画像が張り付けられていなかったので再度質問です。

”仕入表”タブに入力されたデータが横並びのデータです。
例えば、商品コード/品名/価格/色/入荷数 の並び順で、入力されています。一つの品番に対して色数は1から10個あり、色/入荷数/色/入荷数という風に構成されてます。

そこでこちらでお世話になり、仕入表に入力したデータを縦並びに色別で”在庫表”タブに表を作れるようなVBAを教えていただきました。

画像の仕入表は上の表で、下の表が在庫表に転記されたときの例です。
因みにその時のVBAはこちらです。


Sub Sample4() '//この行から
Dim i As Long, j As Long, cnt As Long, lastRow As Long, wS As Worksheet
Application.Calculation = xlCalculationManual
Set wS = Worksheets("仕入表")
With Worksheets("在庫表")
'//E列で「在庫表」Sheetの最終行取得★
lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
'//「在庫表」SheetにデータがあればD列2行目~I列最終行データを一旦消去
If lastRow > 1 Then
.Range(.Cells(2, "D"), .Cells(lastRow, "I")).ClearContents
End If
cnt = 1
For i = 3 To wS.Cells(Rows.Count, "A").End(xlUp).Row '//「仕入表」Sheetの3行目~A列最終行まで
For j = 5 To wS.Cells(i, Columns.Count).End(xlToLeft).Column Step 2 '//E列~i行最終列まで2行毎★
If wS.Cells(i, j) <> 0 Then '//画像で「0」が表示されているので「0」以外を追加★
cnt = cnt + 1
'//最初のデータ行のみ「仕入表」Sheetの日付をD列に表示★
If j = 5 Then
.Cells(cnt, "D") = wS.Cells(i, "A")
End If
.Cells(cnt, "E") = wS.Cells(i, "B") '//B列に「コード」を表示
.Cells(cnt, "F") = wS.Cells(i, "C") '//F列に「商品名」を表示
.Cells(cnt, "G") = wS.Cells(i, "D") '//G列に「下代」を表示
.Cells(cnt, "H") = wS.Cells(i, j) '//H列に「色」を表示
.Cells(cnt, "I") = wS.Cells(i, j + 1) '//I列に「数」を表示
End If
Next j
Next i
'//最後にD列の表示形式(日付)を「在庫表」SheetのA3セルの書式に設定★
.Range("D1", Cells(Rows.Count, 4).End(xlUp)).NumberFormatLocal = wS.Range("A3").NumberFormatLocal
End With
Application.Calculation = xlCalculationAutomatic
End Sub '//この行まで


そこで、また新たにもしできるなら教えていただきたいことが出てきました。
仕入表タブのC列に出荷した商品が出たら「出荷済」と入力していますが(画像ではA列から埋まってますが実際はA~Cは空白にしてます)、”出荷済”にしたときに在庫表タブの同じ品番の商品すべて(日付~すべての色の個数まで)を黄色の色付けにすることはできますか?
もしできるとすごく楽になるのですが・・・
それではよろしくお願いします。

いつもこちらで皆さんに助けていただいてます。昨日質問しましたが画像が張り付けられていなかったので再度質問です。

”仕入表”タブに入力されたデータが横並びのデータです。
例えば、商品コード/品名/価格/色/入荷数 の並び順で、入力されています。一つの品番に対して色数は1から10個あり、色/入荷数/色/入荷数という風に構成されてます。

そこでこちらでお世話になり、仕入表に入力したデータを縦並びに色別で”在庫表”タブに表を作れるようなVBAを教えていただきました。

画像の仕入表は上の表で...続きを読む

Aベストアンサー

No6です。
以下の箇所を修正しました。前回のマクロをこれで入れ替えてください。
1)エラー13で型が一致しません。・・・この対策
色の箇所が0以外なら処理しているのを、空白以外なら処理するようにしました。
2)今更ですが黄色の色付けを日付の列だけにすることは可能でしょうか。
日付の列だけ黄色にしました。
-------------------------------------------------------
Sub Sample4() '//この行から
Dim i As Long, j As Long, cnt As Long, lastRow As Long, wS As Worksheet
Dim wns As Worksheet
Application.Calculation = xlCalculationManual
Set wS = Worksheets("仕入表")
Set wns = Worksheets("納品仕訳")
Worksheets("在庫表").Activate '追加
With Worksheets("在庫表")
'//E列で「在庫表」Sheetの最終行取得★
lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
'//「在庫表」SheetにデータがあればD列2行目~I列最終行データを一旦消去
If lastRow > 1 Then
.Range(.Cells(2, "D"), .Cells(lastRow, "I")).ClearContents
.Range(.Cells(2, "D"), .Cells(lastRow, "I")).Interior.Pattern = xlNone
End If
cnt = 1
For i = 3 To wS.Cells(Rows.Count, "A").End(xlUp).Row '//「仕入表」Sheetの3行目~A列最終行まで
For j = 5 To wS.Cells(i, Columns.Count).End(xlToLeft).Column Step 2 '//E列~i行最終列まで2行毎★
If wS.Cells(i, j) <> "" Then '//画像で「0」が表示されているので「0」以外を追加★ '修正
cnt = cnt + 1
'//最初のデータ行のみ「仕入表」Sheetの日付をD列に表示★
If j = 5 Then
.Cells(cnt, "D") = wS.Cells(i, "A")
End If
.Cells(cnt, "E") = wS.Cells(i, "B") '//B列に「コード」を表示
.Cells(cnt, "F") = wS.Cells(i, "C") '//F列に「商品名」を表示
.Cells(cnt, "G") = wS.Cells(i, "D") '//G列に「下代」を表示
.Cells(cnt, "H") = wS.Cells(i, j) '//H列に「色」を表示
.Cells(cnt, "I") = wS.Cells(i, j + 1) '//I列に「数」を表示
If wns.Cells(i + 2, "C").Value = "出荷済" Then
.Range("D" & cnt).Interior.Color = 65535 '修正
End If
End If
Next j
Next i
'//最後にD列の表示形式(日付)を「在庫表」SheetのA3セルの書式に設定★
.Range("D1", Cells(Rows.Count, 4).End(xlUp)).NumberFormatLocal = wS.Range("A3").NumberFormatLocal
End With
Application.Calculation = xlCalculationAutomatic
End Sub '//この行まで
-------------------------------------

No6です。
以下の箇所を修正しました。前回のマクロをこれで入れ替えてください。
1)エラー13で型が一致しません。・・・この対策
色の箇所が0以外なら処理しているのを、空白以外なら処理するようにしました。
2)今更ですが黄色の色付けを日付の列だけにすることは可能でしょうか。
日付の列だけ黄色にしました。
-------------------------------------------------------
Sub Sample4() '//この行から
Dim i As Long, j As Long, cnt As Long, lastRow As Long, wS As Worksheet
Dim wns As Works...続きを読む

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

QExcelの印刷が出来ません。 このような画面にすぐなってしまいます。 対処方法を教えてください。

Excelの印刷が出来ません。
このような画面にすぐなってしまいます。
対処方法を教えてください。

Aベストアンサー

エクセルの修復インストールをして下さい

Qエクセルvba 一つ上の行を指定した回数分コピーする。

教えて下さい。vba初心者です。

A B C D E F G H
7 522 加藤 沖縄 みかん 縄 1 1/5 空欄
8 123 吉田 愛媛 りんご 水 3 2/10 空欄

1️⃣一番最後に入力した行をすぐ下にコピーしたい。(ここでは7行目…入力して行くと行は増えます。)
2️⃣指定回数はE列。

この列ではE列が3回になりますので、
コピーしたい範囲はA〜G列を、すぐ下の8行〜9行までの2回分コピーしたいです。

完成希望例
A B C D E F G H
7 522 加藤 沖縄 みかん 縄 1 1/5 空欄
8 123 吉田 愛媛 りんご 水 3 2/10 空欄
9 123 吉田 愛媛 りんご 水 3 2/10 空欄
10 123 吉田 愛媛 りんご 水 3 2/10 空欄

にしたいです。

教えて下さい。vba初心者です。

A B C D E F G H
7 522 加藤 沖縄 みかん 縄 1 1/5 空欄
8 123 吉田 愛媛 りんご 水 3 2/10 空欄

1️⃣一番最後に入力した行をすぐ下にコピーしたい。(ここでは7行目…入力して行くと行は増えます。)
2️⃣指定回数はE列。

この列ではE列が3回になりますので、
コピーしたい範囲はA〜G列を、すぐ下の8行〜9行までの2回分コピーしたいです。

完成希望例
A B C D E F G H
...続きを読む

Aベストアンサー

前の絵のリスト範囲の所、名前定義も使えますよ。
というか、数式を入れるところの右のボタンみたいのを
押すと、入力する代わりにマウスで別シートでも
ドラッグで範囲指定できるから、範囲指定とぴったり
合致すれば、勝手に名前に変換されるみたいだった。
名前で指定の時、先頭に=はつけないみたいです。

ボタンはどっちをお使いですか?
呼び出している subの名前で判ります。
Private Sub CommandButton1_Click()
と決まっているのがActiveXの方です。

Q【エクセル VBA】 VBAを使って複数のCSVを結合させたいのですが、コンマ区切りの値がデータ上に

【エクセル VBA】

VBAを使って複数のCSVを結合させたいのですが、コンマ区切りの値がデータ上に存在するため上手くまとまりません。


コマンドでまとめる方法は知っているのですが、どうしてもVBAでやらなければならないので、その方法をご教授下さい。

また、結合するCSVはエクセルを開いた時に選択できるようにしたいです。
(特定のファイル上を対象では無く。)



説明が分かり辛いかもしれませんがよろしくお願いします。

Aベストアンサー

こんにちは

CSVには統一された規格がないので、細部について(コーテーションの種類やコーテーション内でのコーテーションの扱いなど)はいろいろ異なるルールがあり得ます。

対象がどのようなルールのデータなのかによるところは大きいですが…
エクセルでそのまま読み込める形式のCSVであるなら、No2様がおっしゃっているように、エクセルに読み込ませるというVBAを作成するのが簡単でしょう。
読み込めさえすれば、あとは統合処理だけなので比較的簡単だと思います。

エクセルで直接は読み込めないようなルールのデータの場合は、
>コマンドでまとめる方法は知っているのですが~~
とのことなので、手順ははっきりしているのでしょうから、対象のCSVをテキストで読み込み、文字列操作によってその手順で処理を行なえば解釈ができるものと思います。

>また、結合するCSVはエクセルを開いた時に選択できるようにしたいです。
どこかのセルにファイルを指定(記入)したうえでVBAを実行するか、VBAからファイル選択のダイアログを表示して選択させるなどの方法が考えられると思います。

こんにちは

CSVには統一された規格がないので、細部について(コーテーションの種類やコーテーション内でのコーテーションの扱いなど)はいろいろ異なるルールがあり得ます。

対象がどのようなルールのデータなのかによるところは大きいですが…
エクセルでそのまま読み込める形式のCSVであるなら、No2様がおっしゃっているように、エクセルに読み込ませるというVBAを作成するのが簡単でしょう。
読み込めさえすれば、あとは統合処理だけなので比較的簡単だと思います。

エクセルで直接は読み込めないようなルー...続きを読む


人気Q&Aランキング