Results of 1 - 1 of about 384 for フォルダ ブック シート 転記 (0.038 sec.)
フォルダ (4446), ブック (11580), シート (35662), 転記 (4285)
- [[20210212220136]]
- #score: 8791
- @digest: 4d624f7bd4408a9e32ada5cc8f3368e0
- @id: 86708
- @mdate: 2021-02-16T10:14:48Z
- @size: 25722
- @type: text/plain
- #keywords: tgtws (82783), 日誌 (67692), 幸子 (40740), 務報 (40557), namae (25387), 名【 (25166), ム) (22329), 当者 (15697), ルネ (13837), 担当 (12736), 記事 (12657), 個別 (10720), 者名 (9248), ォル (8519), 名( (7468), ファ (7193), ルダ (7152), 転記 (7145), フル (7038), フォ (6329), mypath (6125), ネー (5715), ダ名 (5675), ァイ (5569), 別フ (4882), イル (4732), 業務 (4292), lastrow (4211), 字数 (3575), マナ (3332), thisworkbook (3198), 2021 (3109)
- 『「「業務日報から個別のファイルへ転記させたい」[av[きゃん] について』（幸子）
投稿 [[20201209212549]] 『「業務日報から個別のファイルへ転記させたい」[ax（きゃん） について... きゃんさんのお願いと少し似ていたので、 少し引用させていただきます。 【質問】下記のような時、転記の時のマクロの 式はどのようになりますか? 私も初心者で説明が分かりづらいかと思います。 その際はお手数をおかけしますが質問下さい。 ちなみに似ている所は、きゃんさんの引用しています。 «目的» ★日誌に書かれた内容を担当者別のファイルに 転記をしたいです。フォルダz内のフォルダから フォルダz内の別フォルダへの転記。 «準備» 1つのフォルダを作成しフォルダ名【業務 報告】とします。その中に、フォル ダ名【日誌】とフォルダ名【担当者名(フル ネーム)】があり、この担当者別のフォルダ は全部で75名分あります。 フォルダ名【日誌】の中には、ファイ ル名【日誌】、フォルダ名【担当者名(フル ネーム)】の中には、ファイル名【担当 者名(フルネーム)】と別のファイル(この 別ファイルは今回関係はありません。)が 存在します。 ★書式について ファイル名【担当者名(フルネーム)】の 書式は、75名分、全て同じです。 詳細は、担当者別ファイルの sheet1は『個別記録』という名前にします。 行幅は全て0.77cm。1ページに34行入ります。 1行目A列に『年月日』を中央に 入力(列幅2.22cm)、 1行目B列に『項目』を中央に 入力(列幅1.8cm)、 1行目C列に『記事』を中央に 入力(列幅13.49)、 フォントは11。『記事』の文字数は34文字 まで入力可能です。 2行目から34行目まで、 A列にR2.12.1と転記された日にちと、 C列にはその日の記事の内容が入るように 考えています。B列は空白です。 2枚目以降も、必ずページ1番上に 日付、項 目、記事という言葉が入るように印刷タイ トル設定をします(このタイトル設定は マクロなくても出来るので自分でやれます ので大丈夫です。)。 続いて ファイル名【日誌】の書式は、 sheet1を『日誌』という名前にします。 1行目から3行目までは、行幅は各0.69cm 4行目以降の行幅は全て0.77cmに設定します。 それで、AB列2行3行はセル結合します。 結合した所に『令和2年12月1日』の日付を 手入力します。 A19からA36とA38からA45、A48からA62、 A73からA106、 A108からA141は、『担当 者名(フルネーム)』が入ります(A列幅3.12cm)。 名前の右側に、その方の今日の出来事が『記 事』として入ります。記事は、一行では収まら ない場合があり、 二行目以降になることも あります。そのような場合、二行目以降の担当 者名 は入力しない方が見やすいので、空欄でも 転記できるようにお願いしたいです。 先程のA範囲(A19〜141までの部分的な範囲)で、 名前が2回、3回、4回と使われる事もあります。 また、B19からB36とB38からB45、B48からB62、 B73からB106、 B108からB141は、『記事』を入 力します。それ以外の範囲は関係ないので気にし なくて大丈夫です(A列も同様)。 ちなみにBは、CDEFGHIとセル結合しています。 それぞれの列幅、Bは1.67cm、Cは1.93cm、 Dは1.93cm、 Eは1.67cm、Fは1.67cm、 Gは1.67cm、Hは1.67cm、Iは1.75cmです。 合計13.96cmになります(担当者名と記事のフォ ントは11)。 記事は34文字数に入力制限しま す(マクロを使わずに私の方で設定します。)。 基本的に記事は、上から時系列で入力しますので 転記も 時系列順にお願いできたらと。 日誌の空いているところにマクロを起動する ボタンを作成して実行できるように考えています。 «マクロでのお願い» ★このような書式の中で、お願いしたいこと ファイル名【日誌】のAB19〜AB36とAB38〜 AB45、 AB48〜AB62、AB73〜AB106、 AB108〜AB141 の範囲内で担当者名とその記 事(一行または、それ以上)が、入力された場合、 マクロを実行すると各担当者ごとのフォルダ を探し【担当者名(フルネーム)】ごとのフォ ルダ→ファイル内に、 アクセスし日付(R2.12.1 のような表示)と記事が自動転記されるように して頂きたいです。日付は1回入力されたら、 それ以降表示は されなくて大丈夫です。 転記された記事は34文字数超えると2行目に 移るなど して頂けると助かります。 日誌のファイル拡張子は.xlsmにします。 担当者の拡張子は.xlsxのままです。 また、転記の際はマクロ起動中は ファイルをファイル開いている のだけども、表示されず 終わったらメッセージボックスで 「転記完了」と表示をされる 式を作っていただけると 嬉しいです。 長々とすみません。 また、もし解説も少しのせて頂けると 勉強になりますので助かります。 ＜ 使用 Excel:Excel2013、使用 OS:Windows10 ＞ ---- すごく読みづらいけど、おそらく作成依頼ですよね。 作成依頼には興味がないので1意見ですが、ある程度仕様も決まっているようですし、参考になるトピックも見つけられているようなので、とりあえず手を付けてみて、【わからない部分】を具体的に聞いてみたらどうでしょうか? （もこな2） 2021/02/13(土) 09:13 ---- 【『日誌』シートのA列は、 担当者名で、フィルター可能ですか。 手作業で確認してみてください。 （マナ） 2021/02/13(土) 10:45 ---- 担当者名でフィルター特に考えてないです。 キャンさんの場合は、同じフォルダ内でファイルからファイルの転記ですが、 私が悩んでいるのは、同じフォルダ内のフォルダから別フォルダの移動です。 各フォルダの中にはファイルがそれぞれ入っています。 ★具体的に下の式のどこに入れたら上記の思うような式になるかが わからないです。 1.行の高さ・幅、フォント、データが中央寄せになっているといった情報がありますが、 データを転記するだけですからそのことは考慮する必要はありません。 2.拡張子は .xlsm ということですが、担当者ブックになんらかのマクロを記載するのであればその通りですが、 そうでなければ担当者のファイルは .xlsm にする必要はありません。 提示したコードでは xlsx としてあります。 もし必要があって .xlsm にするのであれば修正してください。（2箇所あります） 3.担当者ブックの名前はフルネームでもいいですけど、日誌のA列の名前と完全一致が条件です。 4.シートは一つしかないのであれは前に提示したコードでいいですが、 今回「個別」というシート名にするということですからその名前を指定してあります。 この場合、担当者ファイルに複数のシートがあっても正常に動きますが、その名前のシートがないとerrorになります。 どちらがいいかはそちらで判断してください。 5.日誌ブックの日付欄は、A2:B3 セルを結合してそこに入力されていると解釈しています。 日付はシリアル値で入力されているものとします。 6.前回までは日誌ブックの記事の文字数を考慮して、一定以上の文字数は事業のセルに表示することとしていましたが、 今回は文字数を限定するということで、それは考慮していません。 セルの文字数はチェックせず転記します。 34文字に制限ということはあらかじめ日誌ファイルで設定しておいてください。 7.転記する記事は、B19からB36、B38からB45、B48からB62、B73からB106、B108からB141、のみを対象としています。 その範囲で空白でないデータを転記します。 空白に見えてもスペースなどが入っていると空白ではないとみなして空白を転記します。 以上を踏まえて次のコードを実行(テスト)してみてください。 Sub test4() ' Dim namae As String 'このシートA列の担当者の名前 Dim lastRow As Long '担当者ブックのC列の最終行 Dim myPath As String '日誌ブックのパス Dim tgtWs As Worksheet '書き込み対象のシート Dim wb As Workbook Dim myR As Range, r As Range Dim hizuke As Date ' Application.ScreenUpdating = False '画面の書き換えを停止する myPath = ThisWorkbook.Path & "¥" With Sheets("日誌") hizuke = Range("A2").Value Set myR = Union(.Range("B19:B36"), .Range("B38:B45"), .Range("B48:B62"), .Range("B73:B106"), .Range("B108:B141")) End With ' For Each r In myR If r.Value <> "" Then 'rセルが空白でない場合に以下のコードを実行する If r.Offset(0, -1).Value <> "" Then namae = r.Offset(0, -1).Value 'rの左セルが空白でなければそのセルの値をnamaeとする。 On Error Resume Next 'エラーが発生したら無視して次の処理に移る Open myPath & namae & ".xlsx" For Append As #1 '担当者ファイルを開く。すでに開かれていたらエラーとなる Close #1 'そのファイルを閉じる On Error GoTo 0 'エラーを無視する命令を中止する If Err.Number > 0 Then '前の処理でエラーが発生していた場合（すでにファイルが開かれていた場合） Set tgtWs = Workbooks(namae & ".xlsx ").Sheets("個別") '名前ブックの個別シートをtgtWsとする Else Workbooks.Open Filename:=myPath & namae & ".xlsx" 'そうじゃ場合mamae.xlsxファイルを開く。 Set tgtWs = ActiveWorkbook.Sheets("個別") '開いたの個別シートをtgtWsとする End If lastRow = tgtWs.Cells(Rows.Count, "C").End(xlUp).Row 'tgtWsのC列の最終行をlastrowとする If tgtWs.Cells(Rows.Count, "A").End(xlUp).Value <> hizuke Then '日付がまだ転記されていなければ転記する tgtWs.Cells(lastRow + 1, "A").Value = hizuke End If tgtWs.Cells(lastRow + 1, "C").Value = r.Value '日誌ファイルの記事を個別ファイルに転記する End If Next ' For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name Then wb.Save: wb.Close 'このブック以外のすべてのブックを保存して閉じる Next ' Application.ScreenUpdating = True '画面の書き換え停止を終了する。 ' End Sub （幸子） 2021/02/13(土) 13:22 ---- こんにちは ^^ ちょい見なのでよくわかりませんが。 myPath の中身を変えれば良いのでは いろいろ、方法があって[マクロとは限りませんが] 、フイルターが可能なら。 取り出したものを、一括で書込みが出来るからなのでは ないでしょうか。いま、テスト環境を拵えています。。 が出来てませんので。テストはまだ出来ませんので 何とも言えませんが。感想だけ。。。(#^.^#)。。。m(_ _)m ↑ 私が作りますという意味ではありませんので、^^;引き続き 回答者様のアドバイスを気長にお待ちください。m(__)m （隠居じーさん） 2021/02/13(土) 14:18 ---- これでもよければ、提示します。 1） ＞日付は1回入力されたら、 ＞それ以降表示は されなくて大丈夫です。 対応しません。条件付き書式等で対応してください。 2） ＞転記された記事は34文字数超えると2行目に ＞移るなど して頂けると助かります。 対応しません。 ＞記事は34文字数に入力制限しま ＞す(マクロを使わずに私の方で設定します。)。 これで、対応してください。 3） ＞また、転記の際はマクロ起動中は ＞ファイルをファイル開いている ＞終わったらメッセージボックスで ＞「転記完了」と表示をされる 対応しません。 4） ＞また、もし解説も少しのせて頂けると 対応しません。（というか苦手なのでできません） 理解のさまたげになるので、動作確認できる最低限のコードにします。 必要ならば、あとで機能追加してください。 5） ＞担当者名でフィルター特に考えてないです。 現在のコードを利用するつもりはありません。 見ちゃうと影響されるので、あえて見ないようにしています。 フィルターを使ったマクロにしようと考えています。 6） 作成依頼でもOKです。そのほうが気楽に回答できます。 ただし、わたしは、提示して、それでお役御免ということで。 （マナ） 2021/02/13(土) 14:24 ---- 提示されたコードは以前私が別の回答をしたときものを写しているようですが、 >キャンさんの場合は、同じフォルダ内でファイルからファイルの転記ですが、 >私が悩んでいるのは、同じフォルダ内のフォルダから別フォルダの移動です。 myPath = ThisWorkbook.Path & "¥" の部分で別のフォルダを指定すればいいです。 具体的には、元のファイルが【業務報告】というフォルダにあり、その中に【日誌】というフォルダがあるようなので 上記の部分を mypath = ThisWorkbook.Path & "¥日誌¥" のように書き換えればいいはずです。 （tora） 2021/02/13(土) 14:27 ---- 追加 7） ＞日付(R2.12.1のような表示) 対応しません。書式設定しておけばよいだけ。 （マナ） 2021/02/13(土) 14:40 ---- 隠居じーさんさんコメントありがとうございます。 マナさんもコメントありがとうございます。 マナさんフィルターを使ったマクロとはどういうことでしょうか?イメージがちょっとわかないです。教えて頂けると。 toraさんありがとうございます。キャンのやり取り見させて頂きました。 とても参考になっています。 toraさんに聞きたいのですが、 上記のコメント通りに入れたら私の思っているようになりますか? 具体的にキャンさんが使用した書式をそのまま使わせて頂き、私なりに少しアレンジを加えられたらと 思いまして。 «やりたいこと» フォルダ【業務報告】の中に、フォルダ名【日誌】とフォルダ名【担当者名(フルネーム)】×75名分があり、 フォルダ名【日誌】の中にはファイル名【日誌】があります。←toraさんが作って頂いたマクロ(修正後のもの)を入れます。 フォルダ名【担当者名(フルネーム)】の中にファイル名【担当者名(フルネーム)】があります。 ファイルはキャンさんが指定したもののExcelファイルの書式を使う場合です。 そのような場合 ファイル【日誌】に記録されたものを担当者別のフォルダに入りファイルに転記するには 具体的にどこの式を修正したら良いですか? すみませんがアドバイスをお願いします。 （幸子） 2021/02/13(土) 15:01 ---- >上記のコメント通りに入れたら私の思っているようになりますか? とりあえずやってみればどうですか。 そのフォルターの中に目的のファイルがあればできると思います。 もちろん実際のデータを使用する場合は必ずバックアップを取ってください。 >ファイル【日誌】に記録されたものを担当者別のフォルダに入りファイルに転記するには >具体的にどこの式を修正したら良いですか? 以前の書き込みを見たならわかると思いますが、 Set myR = Union(.Range("B19:B36"), .Range("B38:B45"), .Range("B48:B62"), .Range("B73:B106"), .Range("B108:B141")) この中のRange( ) のセルが転記するデータがある範囲です。(空白セルは転記しません) Set tgtWs = Workbooks(namae & ".xlsx ").Sheets("個別") '名前ブックの個別シートをtgtWsとする これが転記先のシート名です。 tgtWs.Cells(lastRow + 1, "C").Value = r.Value '日誌ファイルの記事を個別ファイルに転記する このイコールの左側が転記先のセルです。 実際の名前や範囲に変更してお試しください。 （tora） 2021/02/13(土) 17:29 ---- toraさんありがとうございます。 明日やって見ます。 （幸子） 2021/02/13(土) 18:53 ---- ゴメンナサイ。本題とはぜ-んぜん関係ないんですけど、ちょっと気になった点が... 2021/02/13(土) 13:22 で幸子さんが掲載されたコードですが、 On Error Resume Next 'エラーが発生したら無視して次の処理に移る Open myPath & namae & ".xlsx" For Append As #1 '担当者ファイルを開く。すでに開かれていたらエラーとなる Close #1 'そのファイルを閉じる On Error GoTo 0 'エラーを無視する命令を中止する If Err.Number > 0 Then '前の処理でエラーが発生していた場合（すでにファイルが開かれていた場合） ↑ココ。 Err.Numberは On Error GoTo 0 によってクリアされるんじゃなかったかと思います。 Sub test() Dim v On Error Resume Next v = 1 / 0 Debug.Print Err.Number On Error GoTo 0 Debug.Print Err.Number End Sub かと言って、Goto 0 の場所は確かにココが妥当でしょうから、 クリアされる前に別の変数に覚えさせ、その変数でエラー発生の有無を判定しないと、 思った通り機能しないのではないかと思います。 (変な所で横やりスミマセン) （白茶） 2021/02/13(土) 19:04 ---- おはようございます。 toraさんの言う通り mypath = ThisWorkbook.Path & "￥日誌￥" を入れましたが 実行エラー1004がでて、デバッグを押したら Workbooks.Open Filename:=myPath & namae & ".xlsx" が黄色くなりました。 すみませんどうしたら良いでしょう。 担当者(フルネーム)別のフォルダを開いて担当者(フルネーム)ファイルを開いて移す事ができません。 （幸子） 2021/02/14(日) 11:09 ---- ＞フィルターを使ったマクロとはどういうことでしょうか?イメージがちょっとわかないです。 担当者名でフィルター抽出できれば 1行ずつ転記しなくても 担当者ごとに、まとめて転記できますよね。 それを繰り返すということです。 手作業なら、それが簡単そうと思いました。 （マナ） 2021/02/14(日) 11:37 ---- 横からですが、「実行エラー1004がでて」と仰るなら、その時点でエラーメッセージとして 「〜〜〜〜〜が見つかりません。ファイル名およびファイルの保存場所が正しいかどうかを確認してください。」って出てきてませんか? そのファイルは、とりあえずExcel君の指摘通り、チェックしてみてはどうですか? （もこな2） 2021/02/14(日) 12:09 ---- マナさん、フィルター抽出ということは、日誌のA行の指定範囲に75名から担当者を選び、記事を記録し転記とううやりかたでしょうか? もこなさん、出てきました。ほぼ初心者に近い私がマクロをやるのは、大変恥ずかしいばかりですが、チェック通りやろうにもなかなかどこにどうしたらいいのかがわからないのです。だから、詳しい方にやりかたをと思いまして。 すみません。 （幸子） 2021/02/14(日) 12:56 ---- ちょっと伝わらなかったようですが、Excel君のエラーメッセージは、「指定されたファイルが見つからないからWorkbooks.Openできません。」つまり、指定されたフォルダに指定されたファイルがみつらないと言ってるわけです。 なので、本当にそのファイルがあるか確認してみてはどうですか? と伝えました。 で、ちゃんとあるのは確認したのですか?（「フォルダパス」と「ファイル名」に間違いはないのですか?） （もこな2） 2021/02/14(日) 13:30 ---- ＞フィルター抽出ということは、日誌のA行の指定範囲に75名から担当者を選び、記事を記録し転記とううやりかたでしょうか? はい。 （マナ） 2021/02/14(日) 13:55 ---- もこな2さん、すみませんがフォルダパスの探し方とそのパスをどこの式にいれたら良いか教えてください。 マナさん、フィルター抽出ですと選ぶのはいい案だと思います。 ただ、日誌の記録は私よりもパソコンに苦手な人がやるのでなるべくシンプルにしたい所があります。toraさんの作って頂いた式ならは 担当者の名前を入力すれば転記できるのでやりやすいかと、 ちなみに担当者をフィルターかけると新しく来た人や途中で辞めた担当者の訂正が私以外がやると大変かと。 （幸子） 2021/02/14(日) 14:29 ---- 動作確認はしていませんが、実行してみてください。 上手く動いてくれたとしても、先に書いたように、コードの説明はできません。 Sub test() Dim fso As Object, f As Object, p As String Dim tbl As Range, c As Range, r As Range Dim d As Date Dim wbn As String Dim n As Long Dim ws As Worksheet, r2 As Range Set fso = CreateObject("scripting.filesystemobject") p = fso.getfolder(ThisWorkbook.Path).parentfolder Set tbl = Range("A18:I999") d = Range("A2").Value Set c = Range("Z1;Z2") c(1).Value = tbl(1).Value Set r = c(1).Offset(, 2) r.Value = tbl(2).Value For Each f In fso.getfolder(p).subfolders n = WorksheetFunction(tbl.Columns(1), f.Name) wbn = f.Path & "¥" & f.Name & ".xlsx" If n > 0 And fso.fileexists(wbn) Then c(2).Value = f.Name tbl.AdvancedFilter xlFilterCopy, c, r Set ws = Workbooks.Open(wbn).Sheets("個別記録") Set r2 = ws.Range("A9999").End(xlUp).Offset(1).Resize(n) r2.Value = d r2.Columns(3).Value = r.CurrentRegion.Offset(1).Value ws.Parent.Close False End If Next c.Clear r.Clear End Sub （マナ） 2021/02/14(日) 14:45 ---- 編集（とFileSystemObjectについて）被ってしまいましたが、そのまま投稿します。 情報を整理すると C:¥業務報告 ├日誌 │└日誌.xlsm ├Aさん │└Aさん.xlsx ├Bさん │└Bさん.xlsx ├Cさん │└Cさん.xlsx ・ ・ のようになっているんですよね? で、おそらく【日誌.xlsm】にマクロを書いているのでしょうから「Thisworkbook.Path」は「C:¥業務報告¥日誌」のようになるでしょう。 しかし、個人ごとの（ファイルが入っている）フォルダは、「C:¥業務報告」の中に入っている個別のフォルダにあるのですから、「C:¥業務報告¥日誌」のなかで探してもダメでしょう。 すなわち、「Thisworkbook.Path」の親フォルダである「C:¥業務報告」の中から、「日誌」という名前"以外"のフォルダの中にあるのですよね。 ちょっと難しくなりますが、このようにフォルダやファイルを対象とした処理をするには、「FileSystemObject」について学んでみるとよいとおもいます。 http://officetanaka.net/excel/vba/filesystemobject/ 踏まえると、対象となるファイルは↓みたいな感じで取得できるんじゃないですか? Sub 研究用01() Dim フォルダ As Object Dim 自フォルダ As Object Set 自フォルダ = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path) For Each フォルダ In 自フォルダ.ParentFolder.SubFolders If フォルダ.Name <> 自フォルダ.Name Then MsgBox フォルダ.Path & "¥" & フォルダ.Name & ".xlsx" & "を開く処理が必要です" End If Next End Sub なお、質問掲示板で提示のあったコードや、ネットで見つけたコードは、眺めたり、実行してみたりするだけだと、なかなかわからないと思うので、ちゃんと【ステップ実行】して、変数に何が格納されているのかとか、どの命令が何をやっているのか、一つずつチェック（命令自体がわからなければネット検索）することをお勧めします。 ※ステップ実行というのが何を言われているかわからなければ↓を読んでみてください。 【ステップ実行】 https://www.239-programing.com/excel-vba/basic/basic023.html http://plus1excel.web.fc2.com/learning/l301/t405.html ついでに↓も覚えてしまいましょう。 【イミディエイトウィンドウ】 https://www.239-programing.com/excel-vba/basic/basic024.html https://excel-ubara.com/excelvba1/EXCELVBA486.html 【ローカルウィンドウ】 https://excel-ubara.com/excelvba4/EXCEL266.html http://excelvba.pc-users.net/fol8/8_2.html （もこな2） 2021/02/14(日) 14:48 ---- 修正 ＞n = WorksheetFunction(tbl.Columns(1), f.Name) ↓ n = WorksheetFunction.countif(tbl.Columns(1), f.Name) （マナ） 2021/02/14(日) 14:49 ---- もう一つ修正（これでも無駄なことしていますが） ＞p = fso.getfolder(ThisWorkbook.Path).parentfolder ↓ p = fso.getparentfoldername(ThisWorkbook.Path) （マナ） 2021/02/14(日) 15:31 ---- マナさんありがとうございます。 明日実行してみます。 もこな2さんありがとうございます。 情報整理の表はその通りです。 頂いたアドレスを勉強させて頂きます。 返信までに少し時間がかかるかと思います。 （幸子） 2021/02/14(日) 18:18 ---- しばらく見ていない間にずいぶん進んだようですね。 マナさんからの回答がありますのであとはお任せします。 ただ私の提示したものが中途半端になっていますので整理しておきます。 途中、白茶さんからご指摘のあったように On Error GoTo 0 の記述場所は不適切でした。 また、担当者ごとのファイルの場所も誤解していました。 もこな2さんが整理されたようなディレクトリだとすると、前回の私の回答は間違っています。 最後に終了時にメッセージを表示するコードを追加して、下記に参考コードを書いておきます。 まだまだ未熟な私ですので動作の保証は致しかねますが、参考になれば幸いです。 Sub test() ' Dim namae As String 'このシートA列の担当者の名前 Dim lastRow As Long '担当者ブックのC列の最終行 Dim myPath As String '日誌ブックのパス Dim myFile As String '担当者ファイル名:フルパスを含む Dim tgtWs As Worksheet '書き込み対象のシート Dim wb As Workbook Dim myR As Range, r As Range Dim hizuke As Date Dim myErr As Long ' Application.ScreenUpdating = False '画面の書き換えを停止する myPath = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path) - 3) & "¥" With ThisWorkbook.Sheets("日誌") hizuke = Range("A2").Value Set myR = Union(.Range("B19:B36"), .Range("B38:B45"), .Range("B48:B62"), .Range("B73:B106"), .Range("B108:B141")) End With ' For Each r In myR If r.Value <> "" Then 'rセルが空白でない場合に以下のコードを実行する If r.Offset(0, -1).Value <> "" Then namae = r.Offset(0, -1).Value 'rの左セルが空白でなければそのセルの値をnamaeとする。 myFile = myPath & namae & "¥" & namae & ".xlsx" 'myFieは担当者ファイル End If On Error Resume Next 'エラーが発生したら無視して次の処理に移る Open myFile For Append As #1 '担当者ファイルを開く。すでに開かれていたらエラーとなる Close #1 'そのファイルを閉じる myErr = Err.Number 'エラーナンバーを myErrに入れる On Error GoTo 0 'エラーを無視する命令を中止する If myErr > 0 Then '前の処理でエラーが発生していた場合（すでにファイルが開かれていた場合） Set tgtWs = Workbooks(namae & ".xlsx").Sheets("個別記録") '名前ブックの個別シートをtgtWsとする Else Workbooks.Open Filename:=myFile 'そうじゃ場合mamae.xlsxファイルを開く。 Set tgtWs = ActiveWorkbook.Sheets("個別記録") '開いたの個別シートをtgtWsとする End If lastRow = tgtWs.Cells(Rows.Count, "C").End(xlUp).Row 'tgtWsのC列の最終行をlastrowとする If tgtWs.Cells(Rows.Count, "A").End(xlUp).Value <> hizuke Then '日付がまだ転記されていなければ転記する tgtWs.Cells(lastRow + 1, "A").Value = hizuke End If tgtWs.Cells(lastRow + 1, "C").Value = r.Value '日誌ファイルの記事を個別ファイルに転記する End If Next ' For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name Then wb.Save: wb.Close 'このブック以外のすべてのブックを保存して閉じる Next ' Application.ScreenUpdating = True '画面の書き換え停止を終了する。 MsgBox "転記が完了しました。" 'メッセージの表示 ' End Sub （tora） 2021/02/15(月) 16:04 ---- toraさんありがとうございます。 明日やって見ます。 （幸子） 2021/02/15(月) 19:03 ---- toraさん、ありがとうございます。 無事出来ました。(*^^)v （幸子） 2021/02/16(火) 19:14... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202102/20210212220136.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97050 documents and 608253 words.
訪問者：