EXCEL VBAについて質問です。
初歩的なことかもしれないですがよろしくお願いいたします。

ファイルを指定のフォルダに保存したいのですが、
その際シートのA1にある日付をファイル名にして、そのファイル名と同じファイルが指定のフォルダに存在していないか確認して、存在していなければ保存。
存在していればメッセージを出し中断。
以上のようなものを作りたいのですがどのように組めばよいでしょうか?

日付は「yyyy\年mm\月dd\日aaaa」で指定したいと思います。



すみませんがよろしくお願いいたします。

A 回答 (3件)

> 日付は「yyyy\年mm\月dd\日aaaa」で指定したい


とありますが、この中の「\」の意味が分からないので無視しました。

myFile=A1セルの日付を"yyyy年mm月dd日aaaa"としたもの+".xlsm"とします。
myPath="指定フォルダのパス"+"\" とします。
条件分岐で、もし"指定フォルダのパス"にmyFileが存在しなければ
マクロを書いたブックのコピーを指定フォルダに保存します。
存在する場合は"同名ファイルが既に存在します!"と表示しマクロを終了します。

Sub test()
Dim myFile As String, myPath As String
myFile = Format(Range("A1").Value, "yyyy年mm月dd日aaaa") & ".xlsm"
myPath = "指定フォルダのパス" & "\"
If Dir(myPath & myFile) = "" Then
ThisWorkbook.SaveCopyAs myPath & myFile
Else
MsgBox "同名ファイルが既に存在します!", vbExclamation
End If
End Sub
    • good
    • 0
この回答へのお礼

回答遅くなりすみませんでした。

無事に解決することができました。
回答ありがとうございました。

お礼日時:2017/07/18 11:44

No,1です。


No.2の方の回答を拝見して
セルの式 ="C:\"&TEXT(A1,"yyyy\年mm\月dd\日aaaa")&"xlsm"
でパスとファイル名が決められますね。
    • good
    • 0
この回答へのお礼

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

無事に解決できました。
ありがとうございます。

お礼日時:2017/07/18 11:43

どこか、空いているセルに


=TEXT(A1,"yyyy")&"\年"& TEXT(A1,"mm")&"月\"&TEXT(A1,"dd")&"日"&TEXT(A1,"aaaa")&".xlsx"
と関数で、ご希望のフォルダ、ファイル名のパスを表示させておいて

Sub ボタン1_Click()
ThisWorkbook.SaveAs Range("関数をいれたセル").Value
End Sub

を実行すれば
存在していなければ保存。
存在していればメッセージを出し中断。も含めて可能でしょう。

但し、この様な年、月ごとにフォルダ、日ごとにファイルが増えるような管理は通常いたしません。
>初歩的なことかもしれないです・・・・
エクセルを誤った使い方をしてしまう一例です。
お仕事であれば、上司の方か詳しい先輩に一度相談してみて下さい。
エクセルを活用する方法を学びましょう。
    • good
    • 0

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

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

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

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マクロで消去したいです

たびたび同じ質問をしてしまい申し訳ありません
以前教えてもらった
Sub Sample()

Dim c As Range, cbx As Object
Dim rw As Long
Dim t As Single, h As Single, w As Single
Dim y As Single, v As Boolean, f As Boolean

For rw = 6 To 15
Set c = Cells(rw, 1)
t = c.Top
h = t + c.Height
w = c.Width
f = False

' Form Control
For Each cbx In ActiveSheet.CheckBoxes
y = cbx.Top + cbx.Height / 2
If t < y And y < h And cbx.Left < w Then
f = True
If cbx.Value = xlOn Then v = True Else v = False
Exit For
End If
Next cbx

' ActiveX Control
If Not f Then
For Each cbx In ActiveSheet.OLEObjects
If TypeName(cbx.Object) = "CheckBox" Then
y = cbx.Top + cbx.Height / 2
If t < y And y < h And cbx.Left < w Then
f = True
v = cbx.Object.Value
Exit For
End If
End If
Next cbx
End If

If f And v Then
Cells(rw, 3).Resize(, 3).ClearContents
Cells(rw, 16).Resize(, 2).ClearContents
End If
Next rw

End Sub
でシート「操作画面」のC13:E13,P13:Q13 C15:E15,P15:Q15は消去することができました
それを応用して別シート「集計」のI7:I12 K7:K12も合わせて消去しようかと思ったのですが上手く
動作しませんでした

大変申し訳ないのですが、また、ご指導のほどよろしくお願いいたします

たびたび同じ質問をしてしまい申し訳ありません
以前教えてもらった
Sub Sample()

Dim c As Range, cbx As Object
Dim rw As Long
Dim t As Single, h As Single, w As Single
Dim y As Single, v As Boolean, f As Boolean

For rw = 6 To 15
Set c = Cells(rw, 1)
t = c.Top
h = t + c.Height
w = c.Width
f = False

' Form Control
For Each cbx In ActiveSheet.CheckBoxes
y = cbx.Top + cbx.Height / 2
If t < y And y < h And cbx.Left < w Then
f ...続きを読む

Aベストアンサー

前回回答者です。

最初に、前回の説明と重複になってしまいますが・・・
https://oshiete.goo.ne.jp/qa/9807697.html

説明にもありますように、通常はセルとチェックボックスの関係をきちんと取れるようにしておいてから、マクロを作成するものと思います。
その意味において、前回のNo1様、No3様の回答は関係性を確かなものにする方法を提示なさっています。

No2の回答は、それらの情報が与えられないので、しかたなく見た目から推測する方法で処理したものですので、正確性や効率性の点であまり良いものとは言えません。
また、チェックボックスも複数の種類が想定でき、どちらなのかが不明でしたので、両方を考慮しましたが、実際には(常識的に)どちらか一方だけの利用であると推測できますので、結果的に残り半分のコードは不要ということになります。
さらに、きちんと関係性が取れている場合は、位置関係から探す必要もなくなるので、コードも大幅に短くできるはずですが、不明な状況でしたので、ひとまず冗長なコードであっても提示しておけば、後は、質問者様がアレンジなさるであろうことを期待しての回答でした。


今回のご質問で、
・それを応用して~~
・〇〇も合わせて消去しようかと~
・上手く動作しませんでした
「応用する」、「うまく動作しない」という情報だけから推理しようとしても、あまりにも可能性が広がりすぎてしまって皆目見当がつきません。

多少なりともヒントになりそうな情報として記せそうなのは、前回の回答で「セルの内容を消去している」部分は
> Cells(rw, 3).Resize(, 3).ClearContents
> Cells(rw, 16).Resize(, 2).ClearContents
の2行である、ということぐらいでしょうか。
(この部分に関しては、前回のNo3様と、たまたま同様の記述になっています)
ANo3様のコードの方が、シートを明記する形式で対象を指定していますので、より明確な記述方法になっていると言えるかもしれません。

ちなみに
>別シート「集計」のI7:I12 K7:K12を消去する
という部分だけであれば、
 Worksheets("集計").Range("I7:I12,K7:K12").ClearContents
のような記述で実現できるはずと思います。

前回回答者です。

最初に、前回の説明と重複になってしまいますが・・・
https://oshiete.goo.ne.jp/qa/9807697.html

説明にもありますように、通常はセルとチェックボックスの関係をきちんと取れるようにしておいてから、マクロを作成するものと思います。
その意味において、前回のNo1様、No3様の回答は関係性を確かなものにする方法を提示なさっています。

No2の回答は、それらの情報が与えられないので、しかたなく見た目から推測する方法で処理したものですので、正確性や効率性の点であまり良いものとは...続きを読む

QVBAで 別シート(関数が入っている)をB列からに貼り付けるVBAを教えてください。

マクロ超・超初心者です。

【集計用データシート】のデータを【提出用シート】の最終行B列以降にコピーしたいのですが
【提出用シート】のA列が空白にしているためなのか、どうしてもうまくできません。
もう五里霧中です。

概要:
【集計用データシート】は
F7からK16に入っていますが、それぞれのセルは関数を使い、別シートのデータを集計したり日付などを入力させています。
また、F7からK16までのデータは、7行目から16行まで必ずデータがあるとは限りません。日によって7行目にしかデータがない場合もあるし、7行目から16行目までデータがある場合もあります。

【提出用シート】には
データが入っていない最終行のB列からG列に【集計用データシート】のデータを行ごとに貼り付けます。

詳細:
【集計用データシート】
F列7行目から16行目:オーダ番号(別シートのデータを関数を使ってオーダ番号が
                 重複しないよう抽出)
G列7行目から16行目:個数    (別シートのデータを関数を使いオーダ毎の個数を
        集計)
H列7行目から16行目:納期   (別シートのデータを関数を使い納期の日を
                 自動入力)
I列7行目から16行目:寸法確定 (関数を使いF列が空白でない場合、固定文字&quot;寸法確
                定&quot;を入力)
J列7行目から16行目:ABC    (関数を使いF列が空白でない場合、固定文字&quot;AB
                 C&quot;を入力)
K列7行目から16行目:2017/07/08(関数を使いF列が空白でない場合、関数を使い今日
                 の日付を入力)         
      


【提出用シート】B7からG7以降の最終空白行に【集計用データシート】のデータを[行ごとに(例:7行目F列からK列)貼り付けます。
A列:空白にします(必要に応じて後日データを変更した日を入力するため)
B列:AシートのF列(オーダ番号)
C列:AシートのG列(個数)
D列:AシートのH列(納期)
E列:AシートのI列(&quot;寸法確定&quot;)
F列:AシートのJ列(&quot;ABC&quot;)      
G列:AシートのK列(日付)

いろいろ調べたのですがどうしても分かりません。
丸投げの形になり大変申し訳ないですが、よろしくお願いします。

マクロ超・超初心者です。

【集計用データシート】のデータを【提出用シート】の最終行B列以降にコピーしたいのですが
【提出用シート】のA列が空白にしているためなのか、どうしてもうまくできません。
もう五里霧中です。

概要:
【集計用データシート】は
F7からK16に入っていますが、それぞれのセルは関数を使い、別シートのデータを集計したり日付などを入力させています。
また、F7からK16までのデータは、7行目から16行まで必ずデータがあるとは限りません。日によって7行目にしかデータがない...続きを読む

Aベストアンサー

以下のマクロを標準モジュールへ登録してください。
シート名が不明でしたので、「集計用データ」と「提出用」にしています。もし、異なる場合は適切に変更してください。

Option Explicit
Public Sub データコピー()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim row1 As Long
Dim row2 As Long
Dim fromRng As String
Dim toRng As String
Set sh1 = Worksheets("集計用データ")
Set sh2 = Worksheets("提出用")
row2 = sh2.Cells(Rows.Count, "B").End(xlUp).Row + 1
For row1 = 7 To 16
If sh1.Cells(row1, "F").Value = "" Then Exit For
fromRng = "F" & row1 & ":K" & row1
toRng = "B" & row2 & ":G" & row2
sh2.Range(toRng).Value = sh1.Range(fromRng).Value
row2 = row2 + 1
Next
MsgBox ("コピー完了")
End Sub

以下のマクロを標準モジュールへ登録してください。
シート名が不明でしたので、「集計用データ」と「提出用」にしています。もし、異なる場合は適切に変更してください。

Option Explicit
Public Sub データコピー()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim row1 As Long
Dim row2 As Long
Dim fromRng As String
Dim toRng As String
Set sh1 = Worksheets("集計用データ")
Set sh2 = Worksheets("提出用")
row2 = sh2.Cells(Rows.Count, "B").End(xlUp).Row + 1
...続きを読む

QExcel関数 or VBA セルにある数字分、別シートにデータを作成する

・シート1のA1に任意の数字(例えば20)を入力
・シート2のB列(B1~B20)に○○1、○○2、○○3・・・・○○20というように、シート1A1の数字分のデータを作成
※シート1のA1の数字が変われば(例えば5)、シート2のB列(B1~B5)に○○1、○○2、○○3・・・・○○5となるコードを教えて頂けないでしょうか?

何度トライしてもうまくいきません。。。よろしくお願い致します。

Aベストアンサー

こんにちは!

関数での一例です。
Sheet2のB1セルの表示形式をユーザー定義から 000 としておき
=IF(Sheet1!A$1<ROW(),"",ROW())
という数式を入れフィルハンドルで下へコピーしてみてください。m(_ _)m

QEXCELで複数の表からの集計

ある製品αは複数のUNIT(A~C)で構成され、各UNITは複数の部品(あ~お)で構成されるとします。
添付画像のような製品、UNIT構成の場合に製品αを構成する部品数はどのように集計すればよいのでしょうか。

Aベストアンサー

No.8です。

>表に空欄があっても問題ないのでしょうか?

もちろん空白があっても問題ないはずです。
前回の画像の配置で、行方向・列方向にはいくらデータがあっても対応できます。
ただ投稿後思ったのですが、
D列「PART」のデータが各「UNIT」にすべて存在すれば問題ないのですが、
D列データが「UNIT」の中に存在しない!というコトはないですよね?
そうであれば前回のコードで大丈夫なのですが、万一「UNIT」にない場合のエラー処理のために
↓のコードに変更してみてください。

Sub Sample2() '//この行から//
Dim i As Long, k As Long, lastRow As Long
Dim c As Range, r As Range
lastRow = Cells(Rows.Count, "D").End(xlUp).Row
If lastRow > 2 Then
Range(Cells(3, "E"), Cells(lastRow, "E")).ClearContents
End If
For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
Set c = Rows(2).Find(what:=Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
For k = 3 To Cells(Rows.Count, "D").End(xlUp).Row
Set r = Columns(c.Column).Find(what:=Cells(k, "D"), LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then '//←追加★//
With Cells(k, "E")
.Value = .Value + r.Offset(, 1) * Cells(i, "B")
End With
End If '//←追加★//
Next k
Next i
End Sub '//この行まで//

※ 「★」の行を追加しただけです。
「UNIT」にD列データがない場合の処理を追加しました。m(_ _)m

No.8です。

>表に空欄があっても問題ないのでしょうか?

もちろん空白があっても問題ないはずです。
前回の画像の配置で、行方向・列方向にはいくらデータがあっても対応できます。
ただ投稿後思ったのですが、
D列「PART」のデータが各「UNIT」にすべて存在すれば問題ないのですが、
D列データが「UNIT」の中に存在しない!というコトはないですよね?
そうであれば前回のコードで大丈夫なのですが、万一「UNIT」にない場合のエラー処理のために
↓のコードに変更してみてください。

Sub Sample2() '//この行...続きを読む

QエクセルVBA 初心者です。どなたか教えて下さい。

エクセルで以下の事をしたいと考えていますが出来ません。
どなたか教えて下さい。
例として、
A列のセルに、●と◯と空白のセルがあります。
図示しますと以下のようになっています。
   A
1
2
3  ◯
4
5
6  ●
7
8  ●
9
10

となっているものを
例えば、A1から数えて、A6にある●は5つ目にあるので、●を5に替える。
A8の●はA6から数えて、2つ目なので、●を2に替える。
A3にある◯は無視してそのままとしたのですが、
DO~ Loopステートメント
Sub 空白()
Dim i As Integer
i = 1
Range("A1").Select
Do Until ActiveCell.Offset(1)(ActiveCell = "●")
ActiveCell.Offset(1).Select
i = i + 1
If ActiveCell <> "" Then Exit Do
Loop
ActiveCell.Value = i
ActiveCell.Offset(1).Select
End sub
まで考えたのですが、◯を無視することと、変数iを初期化する方法が解りません。
よろしくお願いします。

エクセルで以下の事をしたいと考えていますが出来ません。
どなたか教えて下さい。
例として、
A列のセルに、●と◯と空白のセルがあります。
図示しますと以下のようになっています。
   A
1
2
3  ◯
4
5
6  ●
7
8  ●
9
10

となっているものを
例えば、A1から数えて、A6にある●は5つ目にあるので、●を5に替える。
A8の●はA6から数えて、2つ目なので、●を2に替える。
A3にある◯は無視してそのままとしたのですが、
DO~ Loopステートメント
Sub 空白()
Dim i As Integer
...続きを読む

Aベストアンサー

No.4 の補足

字下げが無いと見難いのでイメージを付けておきます。

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...続きを読む

Qexcel vbaで日付一致の行にデータ転記

excelで営業の業績管理システムを作成しています。
シート1はメニュー
コンボボックス1に⚪年⚪月
2に担当者
3に担当者コード
また、各シートにを開くボタンを設置、

シート2にメニューの該当月のカレンダーがA列に
自動作成・・・1(火)
1ヶ月の日付すべて入っています。
またこのシートが各担当者ごとと、全体確認様シートを作成してあります。

シート5にはフォームで担当者の入力データを記入するようになっています。
A列 5桁数字 00001・・・
B列 日付が⚪⚪⚪⚪年⚪月⚪日
C列 担当者No
D列 担当者
E列から獲得数字
が入力されています。
ちなみにシート5は担当者全員のデータが記入されるシートになっています。
このシート5も各担当者ごとに転記されているシートも作成してありますがメニューの月のフィルターはかかっていません。


この担当者ごとのデータからメニューシートの月を絞りこみ、シート2の各担当者のシートに日付一致でデータを転記していきたいのですが、どなたかご教示いただけませんか?

各担当者のデータからではなく、シート5のすべてのデータから転記の方が早ければそれでもかまいません。
宜しくお願い致します。

excelで営業の業績管理システムを作成しています。
シート1はメニュー
コンボボックス1に⚪年⚪月
2に担当者
3に担当者コード
また、各シートにを開くボタンを設置、

シート2にメニューの該当月のカレンダーがA列に
自動作成・・・1(火)
1ヶ月の日付すべて入っています。
またこのシートが各担当者ごとと、全体確認様シートを作成してあります。

シート5にはフォームで担当者の入力データを記入するようになっています。
A列 5桁...続きを読む

Aベストアンサー

では、これでどうでしょう。
(素直なコードが書けなくて、すいません)

Sub sample()
With Sheets("Sheet2").Range("B3:D23")
.Formula = "=SUMIFS(Sheet5!E:E,Sheet5!$D:$D,$D$1,Sheet5!$B:$B,$A3)"
.Value = .Value
.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
End Sub

Qsleep()関数の質問です・

毎年初心者で、77歳になりました。よろしくお願いします。
visual basic studio express 2013 で勉強しています。

Imports System.Threading.Thread
Public Class Form1

Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Sleep(1000)
Application.DoEvents()
TextBox1.Text = "kingdom" & vbCrLf
Sleep(5000)
Application.DoEvents()
TextBox1.Text &= "koseki tosihiro"
End Sub
End Class

このように一つの関数(なんと言えばいいのですか?)
の中に 二つの slleep(1000),sleep(5000) を使う事はできないのですか?かなり時間がたって
表示されます。

毎年初心者で、77歳になりました。よろしくお願いします。
visual basic studio express 2013 で勉強しています。

Imports System.Threading.Thread
Public Class Form1

Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Sleep(1000)
Application.DoEvents()
TextBox1.Text = "kingdom" & vbCrLf
Sleep(5000)
Application.DoEvents()
TextBox1.Text &= "koseki tosihiro"
End Sub
End Class

こ...続きを読む

Aベストアンサー

>二つの slleep(1000),sleep(5000) を使う事はできないのですか?
使えます。

Sleep(1000)
TextBox1.Text = "kingdom" & vbCrLf
Application.DoEvents()
Sleep(5000)
TextBox1.Text &= "koseki tosihiro"
Application.DoEvents()

のようにしてください。
テキストボックスに文字をセットした後で、
Application.DoEvents()
を呼び出すと、直ちに表示が可能になります。

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&Aを見た人がよく見るQ&A

人気Q&Aランキング