質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

5回答

1899閲覧

VBA 他のブックから名前を参照して、名前の数分、値を同じ名前と日付のセルに入れたい

beginner101

総合スコア18

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2020/08/03 07:43

編集2020/08/05 01:26

前提・実現したいこと

別のブックにあるスケジュールの作業名を工数表の項目と日付が一緒のところのセルに工数の値
を入力したいのですが、
VBAの内容に何が足りていないのかが分からず、悩んでいます。
どこを改良すればうまく動きますでしょうか。

手順
転記元ファイルのシート1のEからRまでの範囲を一列ごとに指定
空なら翌日に移動
列の単語ごとに何個ずつあるか計算し、0.5を掛ける
出した値を列の日付と項目の名前が同じところにあるセルに入力
その列で単語がなくなるまで繰り返す
単語がなくなったら翌日の実績列に移動
日曜日まで終わったら隣のシートに移動
シートがなくなるまで繰り返す

転記元のシート名は毎回異なる
転記元の日付は日付が入っているセルの左に書いてある

予定表 一週間ごとに別のシート ここの作業名の数を合計して0.5掛ける その他は無視する

イメージ説明

工数表 項目は複数存在
イメージ説明

↓マクロ起動後

イメージ説明

工数がM4セルから入力される。
集計し終わったら、下の項目に移動して、項目がなくなるまで続ける

該当のソースコード

Sub KosuBook() Dim ex As Excel.Application '処理用Excel Dim wb As Workbook Dim sPath 'ブックファイルパス Dim sht As Worksheet '参照シート Dim bFlg As Boolean Dim kRow As Long Dim cnt As Long Dim i, j, k, kosu As Long '開くブックを指定 sPath = "〇〇〇.xlsm" '既に開かれているか確認 bFlg = IsBookOpened(sPath) '開かれている場合 If bFlg = True Then Set ex = New Excel.Application '新規Excelで読み取り専用で開く Set wb = ex.Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True) Else '現ブックで読み取り専用で開く Set wb = Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True) End If '工数を集計後、同じ工数にあたる項目を探し、合計を入力する '1yori '1と後の数字名シートの数だけ繰り返し For i = 1 To Worksheets.Count '列ごとに繰り返し For j = 6 To 18 Step 2 '最後のセルまで取得 kRow = Cells(Rows.Count, j).End(xlUp).Row '調べる作業名(重複は除く) k = 0 Do n = InStr(k + 1, kRow, '作業名) If k = 0 Then Exit Do Else cnt = cnt + 1 End If Loop kousu = cnt * 0.5 '工数表のブックへ内容をコピー Next j Next i 'ブックを閉じる Call wb.Close If bFlg = True Then Call ex.Application.Quit End If End Sub 'ブックオープン判定関数 Function IsBookOpened(a_sFilePath) As Boolean On Error Resume Next '保存済みのブックか判定 Open a_sFilePath For Append As #1 Close #1 If Err.Number > 0 Then '既に開かれている場合 IsBookOpened = True Else '開かれていない場合 IsBookOpened = False End If End Function

補足情報(FW/ツールのバージョンなど)

win10(64bit)

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

meg_

2020/08/03 08:13

現状どうなっていて何に困っているのでしょうか?
beginner101

2020/08/03 08:36

別のブックに計算した値を、日付と項目名で一致したセルに入力する方法が思い浮かばないのです。
mako1972

2020/08/03 12:02 編集

質問の投稿は、依頼内容がくわしくプログラムも提示していただいていますが、 Aさんの場合で、少し抽象的に表現されて質問されたほうがよろしいかと思います。 回答しようにも、様々な要素がまじっていて回答しようがないためです。 工程数が複数存在etc 提案ですけど、この内容で個人ファイルごとに必要な行のみ、項目のみに絞って 抽象的なシートを提示していただけるとサンプルが提示できると思います。
meg_

2020/08/03 13:16

> 別のブックに計算した値を、日付と項目名で一致したセルに入力する方法が思い浮かばないのです。 よく分かりません。”別のブックに計算した値”とはどれのこと(どのセル)ですか? 欲しい結果のシートも掲載いただいた方が伝わるかと思います。
beginner101

2020/08/04 00:09

例えば予定表の実績に7/1に出願を1.5行ったので、3つ出願を行った時間帯に入れてからマクロを起動させると、工数表の項目と同じ名前で、行った日付が一緒なので、工数表のM4セルに1.5を入れる といったように動かしたいのです。
meg_

2020/08/04 00:28

質問の工程表の画像は既にマクロ実行後(想定)のシートですか? 質問文からは読み取れませんが。
beginner101

2020/08/04 00:56

そうです。想定後のシートが工数表の内容です。
meg_

2020/08/04 03:55

> 想定後のシートが工数表の内容です。 これは分かりにくいですね。。 インプットとアウトプットを明確にしないと回答は付きにくいかと思います。
mako1972

2020/08/04 04:28

なるほど。今回の説明で理解しました。 工数表 項目は複数存在しており。 →9行ごとに一覧化・すべてマスタ化されているということでしょうか。
beginner101

2020/08/04 04:40

一応項目は9行ごとに分けられていますが、将来的には増えるかもしれません。 項目はマスタ化はしていません。
mako1972

2020/08/04 05:09

現在、時間をとれないので回答できませんが。 フォルダ内の配置・ファイル構成を提示していただくとよいかと思います。
beginner101

2020/08/04 05:28

自分のPCにあるOneDriveのファイルの一つに予定表、工数表.xlsmのファイルがあり、 シート名は予定表が 作業一覧、1~5という名前のシート 工数表は、マスタ、詳細、試作1のシートとなっています。 1~5に予定表の作業の実数があり、詳細に工数表の内容があります。
meg_

2020/08/05 12:19

予定表シートは担当者別になっているのですか? 工数表の「担当」欄との照合はどうなっていますか?
beginner101

2020/08/06 00:07

担当者は予定表には含まれておらず、そのブック自体が担当者の作業内容となっています。 予定表にも担当者欄を追加したほうがいいですか?
meg_

2020/08/06 01:50

ではブック名が担当者名でしょうか?
beginner101

2020/08/06 04:31

202007_09(担当者名)_作業予定表 こんな感じです。
guest

回答5

0

ベストアンサー

マクロを予定表側に組んでみました。

VBA

1Sub KosuBook() 2 Const cnsRowKousuHizuke = 3 3 Const cnsRowKousuBgn = 4 4 Const cnsColKousuKomoku = 4 5 Const cnsColKousuBgn = 13 6 Const cnsRowYoteiHizuke = 1 7 Const cnsRowYoteiBgn = 3 8 Const cnsColYoteiBgn = 6 9 10 Dim wbkKousu As Workbook 11 Dim wshKousu As Worksheet 12 Dim strPath As String 13 Dim lngRowKousuEnd As Long 14 Dim lngColKousuEnd As Long 15 Dim lngRowKousu As Long 16 Dim lngColKousu As Long 17 Dim lngRowYoteiEnd As Long 18 Dim lngColYoteiEnd As Long 19 Dim lngRow As Long 20 Dim lngCol As Long 21 Dim lngWshNum As Long 22 Dim dctRowKomoku As Dictionary 23 Dim dctColHizuke As Dictionary 24 25 Set dctRowKomoku = New Dictionary 26 Set dctColHizuke = New Dictionary 27 28 strPath = "工数表は5シート目.xlsm" 29 Set wbkKousu = Workbooks.Open(strPath) 30 Set wshKousu = wbkKousu.Worksheets(5) 31 32 lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row 33 lngRow = cnsRowKousuBgn 34 Do Until lngRow > lngRowKousuEnd 35 '2020/08/21 14:29 upd start 36' dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow 37 If Trim(wshKousu.Cells(lngRow, cnsColKousuKomoku).Value) <> "" Then 38 dctRowKomoku.Add Trim(wshKousu.Cells(lngRow, cnsColKousuKomoku).Value), lngRow 39 End If 40 '2020/08/21 14:29 upd end 41 lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row 42 Loop 43 44 lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column 45 For lngCol = cnsColKousuBgn To lngColKousuEnd 46 dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol 47 Next lngCol 48 '2020/08/21 15:25 add start 49 wshKousu.Range(wshKousu.Cells(cnsRowKousuBgn, cnsColKousuBgn), wshKousu.Cells(lngRowKousuEnd, lngColKousuEnd)).ClearContents 50 '2020/08/21 15:25 add end 51 For lngWshNum = 1 To ThisWorkbook.Worksheets.Count 52 With ThisWorkbook.Worksheets(lngWshNum) 53 lngColYoteiEnd = cnsColYoteiBgn + 12 54 For lngCol = cnsColYoteiBgn To lngColYoteiEnd Step 2 55 lngRowYoteiEnd = .Cells(Rows.Count, lngCol).End(xlUp).Row 56 For lngRow = cnsRowYoteiBgn To lngRowYoteiEnd 57 '2020/08/21 14:29 upd start 58' lngRowKousu = dctRowKomoku.Item(.Cells(lngRow, lngCol).Value) 59 lngRowKousu = dctRowKomoku.Item(Trim(.Cells(lngRow, lngCol).Value)) 60 '2020/08/21 14:29 upd end 61 lngColKousu = dctColHizuke.Item(.Cells(cnsRowYoteiHizuke, lngCol - 1).Value) 62 If lngRowKousu > 0 And lngColKousu > 0 Then 63 wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5 64 End If 65 Next lngRow 66 Next lngCol 67 End With 68 Next lngWshNum 69 70 wbkKousu.Close SaveChanges:=True: Set wbkKousu = Nothing 71 Set wshKousu = Nothing 72 Set dctColHizuke = Nothing 73 Set dctRowKomoku = Nothing 74 75End Sub

投稿2020/08/21 03:27

編集2020/08/22 08:32
kitasue

総合スコア314

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

beginner101

2020/08/21 04:33 編集

工数表から予定表へマクロを書き換えた後、実行しましたが、 For lngCol = cnsColKousuBgn To lngColKousuEnd dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol Next lngCol で、「このキーはすでにこのコレクションの要素が割り当てられています」と表示されます。 止まるまでの変数の値は、 Rows.Count 1048576 lngRow 1048576 lngRowKousuEnd 28 cnsColKousuKomoku 4 lngColKousuEnd 18 Columns.Count 16384 lngCol 15 となっています。 lngCol 13から始まり、15で止まるみたいです。
kitasue

2020/08/21 04:38

工数表の日付が入っているセルは何行目でしょうか。 もし3行目ならば、 Const cnsRowKousuHizuke = 2 を Const cnsRowKousuHizuke = 3 に修正してください。
beginner101

2020/08/21 04:40

3行目ですね。修正してやってみます。
beginner101

2020/08/21 04:54

マクロは起動はしましたが、工数表の工数欄には特に変更点はありませんでした。 このマクロの場合、予定表にあって、項目にない作業名(昼休み、その他)などはどうしていますでしょうか。
kitasue

2020/08/21 05:02

工数表の項目にない項目は何もしません。 確認ですが、工数表の日付や、予定表の日付は、日付型で入っていますか? 予定表の 7月1日(水) や工数表の 7/1 のセルを選択すると、数式バーに、 2020/7/1 と表示されますか?
beginner101

2020/08/21 05:19

それぞれのシートの始まりの日付は、 予定表だと2020/6/29で表示され、 次のシートの1ページ目は、 '1'!Q1+1 その次は、 =E1+1、=G1+1と続いていきます。 工数表だと、2020/7/1 という風になっています。
kitasue

2020/08/21 05:32

それなら、日付は良さそうですね。 プログラムを修正して、項目名から空白を削除してみましたので、お試しいただけないでしょうか。
beginner101

2020/08/21 05:47

工数表から実行してみると、やはり起動自体は成功するものの、 予定表を開いても、特に値が変わっていませんでした。
beginner101

2020/08/21 05:49

サンプルエクセルでも送れればいいのですが
kitasue

2020/08/21 05:51

> 工数表から実行してみると 予定表から実行されたのですよね? > サンプルエクセルでも送れればいいのですが 差し支えなければ拝見します。
beginner101

2020/08/21 05:55

エクセルってテラテイル内で貼れます?
kitasue

2020/08/21 05:59

ごめんなさい。私も数日前に入ったばかりで、それは分からないです。 ところで、プログラムの先頭でConstで行の位置や列の位置を設定していますが、 確認できますか?
kitasue

2020/08/21 06:10 編集

あと、日付の行が2のままでしたので、3に修正していただけますでしょうか。
beginner101

2020/08/21 06:06

少々お待ちください。
beginner101

2020/08/21 06:24 編集

予定表でマクロを実行いたしましたところ、工数表への転記と数の合計は成功しました。 位置も大丈夫そうです。 しかし、何度かテストすると工数表の作業した日付に数字が入っていると、マクロ起動でどんどん加算されていき、 元の数を合わなくなっていきました。 変更や追加分だけ加算する方法はありますでしょうか。
kitasue

2020/08/21 06:28

集計値を初期クリアする処理を追加しました。 それと、Const値を少し修正しました。
beginner101

2020/08/21 06:40 編集

予定表から実施してみましたが、 lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column For lngCol = cnsColKousuBgn To lngColKousuEnd dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol Next lngCol で、「このキーはすでにこのコレクションの要素が割り当てられています」と表示されます。 今度はlngColが13から14で止まります。
kitasue

2020/08/21 06:45

Const cnsRowKousuHizuke = 3 になっていますか?
beginner101

2020/08/21 06:51

修正したところ、 lngRow = cnsRowKousuBgn Do Until lngRow > lngRowKousuEnd dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row Loop で、「このキーはすでにこのコレクションの要素が割り当てられています」と表示されます。 止まるまでの変数の値は、 lngRowKousuEnd 32 lngRow 32 となっています。
kitasue

2020/08/21 07:01

空白項目のチェクを追加しました。
beginner101

2020/08/21 07:12

Const cnsRowKousuHizuke = 3に修正し、 予定表から実施してみましたが、 lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column For lngCol = cnsColKousuBgn To lngColKousuEnd dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol Next lngCol で、「このキーはすでにこのコレクションの要素が割り当てられています」と表示されます。 今度もlngColが13から14で止まります。 もしかして元あった工数に引っかかってるんでしょうか。
kitasue

2020/08/21 07:15

一度マクロのある予定表ブックを閉じてから、再度開いて実行していただけますでしょうか。
beginner101

2020/08/21 07:29

一度閉じましたら、実行できました。 しかし、元あった工数に加算され、もとより増えていきます。
kitasue

2020/08/21 07:32

プログラムを最新のものにしてから保存して閉じてください。そして再度ひらいてプログラムを実行してみてください。
kitasue

2020/08/21 07:42

ごめんなさい。スペルミスがありましたので修正しました。
beginner101

2020/08/21 07:51

ありがとうございます。増えなくなり適切な数に落ち着きました。 最後に予定表の最初に別のシートが入っていた場合、 Set wshKousu = wbkKousu.Worksheets(5)みたいに変更できますか。
kitasue

2020/08/21 07:54

For lngWshNum = 1 の箇所を For lngWshNum = 2 とすると、2シート目から処理します。
beginner101

2020/08/21 08:00

ありがとうございます。 kitasueさん、あなた様のおかげで完成に一歩近づきました。 貴重な時間を割いていただき、感謝のかぎりです。 また質問する際には、お力を貸してもらっても大丈夫でしょうか。
kitasue

2020/08/21 08:05

どうもお疲れ様でした。 私で分ることでしたら、投稿させていただきます。
beginner101

2020/08/21 08:07

本当にありがとうございました。 よろしくお願いいたします。
guest

0

Microsoft Scripting Runtime
を参照設定して、連想配列を使ってやってみました。

VBA

1Sub KosuBook() 2 Const cnsRowKousuHizuke = 2 3 Const cnsRowKousuBgn = 3 4 Const cnsColKousuKomoku = 4 5 Const cnsColKousuBgn = 13 6 Const cnsRowYoteiHizuke = 1 7 Const cnsRowYoteiBgn = 3 8 Const cnsColYoteiBgn = 10 9 10 Dim wbkYotei As Workbook 11 Dim wshKousu As Worksheet 12 Dim strPath As String 13 Dim lngRowKousuEnd As Long 14 Dim lngColKousuEnd As Long 15 Dim lngRowKousu As Long 16 Dim lngColKousu As Long 17 Dim lngRowYoteiEnd As Long 18 Dim lngColYoteiEnd As Long 19 Dim lngRow As Long 20 Dim lngCol As Long 21 Dim lngWshNum As Long 22 Dim dctRowKomoku As Dictionary 23 Dim dctColHizuke As Dictionary 24 25 Set dctRowKomoku = New Dictionary 26 Set dctColHizuke = New Dictionary 27 Set wshKousu = ThisWorkbook.Worksheets(1) 28 29 lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row 30 '2020/08/21 11:26 upd start 31' For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10 32 lngRow = cnsRowKousuBgn 33 Do Until lngRow > lngRowKousuEnd 34 '2020/08/21 11:26 upd end 35 dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow 36 '2020/08/21 11:26 upd start 37' Next lngRow 38 lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row 39 Loop 40 '2020/08/21 11:26 upd end 41 lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column 42 For lngCol = cnsColKousuBgn To lngColKousuEnd 43 dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol 44 Next lngCol 45 46 strPath = "〇〇〇.xlsm" 47 Set wbkYotei = Workbooks.Open(strPath) 48 For lngWshNum = 1 To wbkYotei.Worksheets.Count 49 With wbkYotei.Worksheets(lngWshNum) 50 lngColYoteiEnd = cnsColYoteiBgn + 12 51 For lngCol = cnsColYoteiBgn To lngColYoteiEnd Step 2 52 lngRowYoteiEnd = .Cells(Rows.Count, lngCol).End(xlUp).Row 53 For lngRow = cnsRowYoteiBgn To lngRowYoteiEnd 54 lngRowKousu = dctRowKomoku.Item(.Cells(lngRow, lngCol).Value) 55 lngColKousu = dctColHizuke.Item(.Cells(cnsRowYoteiHizuke, lngCol - 1).Value) 56 If lngRowKousu > 0 And lngColKousu > 0 Then 57 wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5 58 End If 59 Next lngRow 60 Next lngCol 61 End With 62 Next lngWshNum 63 64 wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing 65 Set wshKousu = Nothing 66 Set dctColHizuke = Nothing 67 Set dctRowKomoku = Nothing 68 69End Sub

私の手元ではうまく行ってます。

投稿2020/08/19 14:23

編集2020/08/21 02:38
kitasue

総合スコア314

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

beginner101

2020/08/20 09:03

ありがとうございます。試してみます。
beginner101

2020/08/21 00:37

すみません。ユーザー定義型が定義されていないと Dim dctRowKomoku As Dictionary のところで警告されてしますのですが、何が足りないのでしょうか。
kitasue

2020/08/21 01:10 編集

VBEの[ツール]-[参照設定]で、 Microsoft Scripting Runtime を探し出して、チェックボックスをオンにしてください。
beginner101

2020/08/21 01:52 編集

ありがとうございます。 もう一つ、いいでしょいうか。 For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10 dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow Next lngRow で、「このキーはすでにこのコレクションの要素が割り当てられています」と表示されます。 何に割り当てが行われていますでしょうか。
kitasue

2020/08/21 02:15

ご提示いただいた工数表の内容から判断して、3行目から10行ごとに項目の名称を辞書に登録しています。 ですから、重複の可能性として考えられるのは、 (1) 10行ごととは限らない。  空白を複数回登録しようとしている。 (2) 同じ項目が存在する。 くらいでしょうか。
kitasue

2020/08/21 02:31

プログラムを修正し、10行ごとという処理をやめました。
beginner101

2020/08/21 03:04 編集

修正ありがとうございます。 現在マクロは動きはするのですが、とくにセル内の値に変化はないです。 エクセルファイルが入っているのは自分のCドライブのドキュメント内です。 予定表でマクロ起動であっていますでしょうか。 後工数表内にほかのシートが入っていると邪魔になりますか。 工数表があるシートは、5シート目にあります。
kitasue

2020/08/21 03:05

いえ、工数表から予定表を開く前提でした。。。
kitasue

2020/08/21 03:08

工数表のブックにマクロを組んで、工数表はブックの1シート目という前提です。
beginner101

2020/08/21 04:00

ではそれ以外を消して行ってみます。
kitasue

2020/08/21 04:04

予定表にマクロを組んで、工数表が5シートめにある前提で新たにプログラムを組みましたので、そちらをご覧いただけますでしょうか。
guest

0

まず細かい話ですが、変数がちゃんと宣言されていないようです。
それによるエラーなどは関係ないでしょうか?
また、工数は×0.5しているようなので以下のようにします。

VBA

1Dim n As Long 2Dim kousu As Double

また、列ごとに繰り返すFor i = 1 To Worksheets.CountのFor文のうちn = InStr(k + 1, kRow, '作業名)と記載がありますが、この条件式ではずっと k=0 のままでちゃんとした処理はされないでしょう。
InStr VBAなどで検索して調べてみてください。

他のブックに書きうつすところはまだ検討していませんので、For文のところだけ書き換えてたものを記載します。
追記:ベストアンサーが設定されたようなので他ブックに書き写す部分の処理の検討はしません

これにより、正しいkousuの値が取得できるはずです。
今回は作業名を仮に作業Aとしています。

VBA

1 For i = 1 To Worksheets.Count 2 '列ごとに繰り返し 3 For j = 6 To 18 Step 2 4 'cntが加算されてしまうためリセット 5 cnt = 0 6 7 '最後のセルまで取得 8 kRow = Cells(Rows.Count, j).End(xlUp).Row 9 10 '調べる作業名(重複は除く) 11 If kRow > 2 Then 12 13 For k = 3 To kRow 14 15 '繰り返しているj列の、k行目に目的の作業名があれば cnt+1 16 If InStr(Cells(k, j).Value, "作業A") > 0 Then cnt = cnt + 1 17 18 Next k 19 20 kousu = cnt * 0.5 21 MsgBox (Cells(1, j - 1).Value & "の 作業A工数は:" & kousu) 22 23 ' 工数表のブックへ内容をコピーする処理 24 25 26 End If 27 28 Next j 29 Next i 30

投稿2020/08/19 01:15

編集2020/08/26 02:41
per_

総合スコア41

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

beginner101

2020/08/20 09:03

ご回答ありがとうございます。
guest

0

簡単のために下記としています。

  • マクロブックの1シート目を「予定表」、2シート目を「工数表」とする
  • マクロブック名を担当者名とする

シートは下記とします。
イメージ説明

イメージ説明

VBA

1Sub test() 2 3 Dim tantou As String 4 Dim yotei, kousuu As Worksheet 5 Dim time_start_row, time_end_row As Integer 6 Dim start_column, end_column As Integer 7 Dim date_col As Integer 8 Dim i As Integer 9 10 tantou = Split(ThisWorkbook.Name, ".")(0) 11 Set yotei = ThisWorkbook.Worksheets(1) 12 Set kousuu = ThisWorkbook.Worksheets(2) 13 time_start_row = 3 14 time_end_row = 8 15 start_column = 4 16 end_column = 4 17 18 With yotei 19 For col_index = start_column To end_column Step 2 20 For i = 10 To kousuu.UsedRange.Columns.Count 21 If kousuu.Cells(1, i).Value = .Cells(1, col_index).Value Then 22 date_col = i 23 End If 24 Next i 25 26 For row_index = time_start_row To time_end_row 27 For i = 1 To kousuu.UsedRange.Rows.Count 28 If kousuu.Cells(i, 1).Value = .Cells(row_index, col_index).Value Then 29 If kousuu.Cells(i, 7).Value = tantou Then 30 kousuu.Cells(i, date_col).Value = kousuu.Cells(i, date_col).Value + 0.5 31 End If 32 End If 33 Next i 34 Next row_index 35 Next col_index 36 End With 37 38End Sub 39

投稿2020/08/06 11:42

meg_

総合スコア10577

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

beginner101

2020/08/07 00:57

ご回答ありがとうございます。 このソースとシート構造から、 やはり別のブックから読み取るのは難しく、ブック内の別シート同市のほうが 計算しやすいということでしょうか。
meg_

2020/08/07 05:22

そうではありません。サンプルとして単純な構造にしただけです。 私の回答であれば、下記部分でお好きなブックのシートを指定すれば良いでしょう。 Set yotei = ThisWorkbook.Worksheets(1) Set kousuu = ThisWorkbook.Worksheets(2)
beginner101

2020/08/07 06:00

ありがとうございます。 実行してみます。
guest

0

レスがつかないようですので、コメントさせていただきます。
申し訳ありませんが回答ではありません。今回のご相談は複雑な内容ですので、レスが難しい案件だと思います。
また、レスがついたとしても複雑すぎて理解できずに終わると思います。
(ただ、質問者様はそれなりのスキルがあると思われます)

日付セルが入力されているデータ型がわからないとVBAを組めないetc色々と不明な点が
多く、できればスルーしたい案件となります。
そこで、今回は不明な点・外部シートの読み取りを完全無視し、下記の内容で回答させていただきます。

Aさんのファイルには1週間の予定が5シート存在し、6シート目に工程表があるとします。
シート工程表では、1行目にあるABC WEB出願という項目を日別に集計する。

というサンプルです。工程表・イミディエイトウィンドウには集計数を表示します。
これが組めないと、フォルダ内の個々のファイル処理が組めないと思います。
質問者様の処理内容は、さらに複雑な内容となるためです。

データ便へUP:サンプルダウンロード

以上 まずサンプルを消化していただくか、他の方のレスをお待ちください。

投稿2020/08/04 12:32

編集2020/08/04 12:46
mako1972

総合スコア383

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

mako1972

2020/08/04 12:51

複雑というか、不明な点が多いため、上級者の方の回答を待ちましょう・・。
beginner101

2020/08/05 00:15

すみません、サンプルでもありがとうございます。 日付は2020/7/1のようになっています。 より詳しい内容も求められたら回答いたします。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問