[[20210126161227]] 『月報のまとめをしたい』(hana) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『月報のまとめをしたい』(hana)

社内のシステムが使えなくなってしまいました。
直せる人もいないので、新たに外注する予定ですが
暫定的に、最低限の部分だけ何とかマクロで出来ないかと考えています。

月報として個人毎のシートで纏めているデータがあります
150程シートが存在します。

L9に名前が入っています。

45〜53行(最大)にデータがあります。

     C      D      I
45 工事No 現場名 日数
46   11   事務所 16
47 301   ●工事   3
・
・
・
53

これを、集計用のExcelファイルに以下のように取り込みたいです。
イメージとしては、
・対象月をどこかに入力してマクロボタンを押下。(以下シート名とA1のYYYYMM部分になる)
・シート追加(シート名は"YYYY年MM月個人別")
・月報を選択する。
・月報の一番右のシート以外を全て抽出する。

抽出は以下のようにしたいです。

    A      B      C      D        E        F
1□□□YYYY年MM月 月間就労時間一覧表(個人別) □□□
2 社員No  氏名   工事No 工事名称 稼働日数 作業時間
3  001    田中    11    事務所             120.00
4                301    ●工事              22.50
5                      【個人名】 19       142.50
6  002    佐藤   302    ×工事             150.00
7                      【個人名】 20       150.00
.
.
.

作業時間は稼働日数×7.5です。残業は考慮しなくても良いです。
社員Noは若い順から表示したいです。
社員Noはマクロボタンを設置するシートのB列、名前はC列にデータがあります。
(逆の方がいいでしょうか)

その他必要な情報はありますでしょうか。
大変申し訳ないのですが、どなたかよろしくおねがいします。

この動作が完成したら、次の工程も質問させていただきたいです。

< 使用 Excel:Excel2016、使用 OS:Windows10 >


困っている部分はどこですか?

>直せる人もいないので、新たに外注する予定
>どなたかよろしくおねがいします。
と仰っているので、とりあえず版をタダで作ってほしいということなのでしょうか?

そういう話しであれば興味がないので私は撤退しますが、自分でがんばってみるということなら

 (1)シートを追加する
 (2)追加したシートの名前を変える
 (3)ダイアログを出して、ユーザーに月報ファイルを選んでもらう
 (4)↑を開く
 (5)↑の1番目〜最後−1番目のシートを巡回して

 (6)シート名を(1)に書き出して
 (7)シートの内容を(1)コピペして

 (8)(4)で開いたブックを閉じて
 (9)(6)をキーに社員Noを調べて(1)に書き込んで
 (10)(9)をキーに並び替えして
 (11)A列を上から順に見ていき、1行上と同じ値ならA〜B列をクリア

という処理にすれば実現可能だとおもいます。

(もこな2) 2021/01/26(火) 20:53


もこな2様

自身で頑張りますので、お力添えをしていただけますと幸です。
手順を示していただいたことで、どこからどうやって手を付けていいかわからない状態から
脱することができました。ありがとうございます。

ただ、今まで簡単な改修しか行ったことがありません。
調べつつ進めてみましたが、上記(5)〜の所で詰まってしまいました。

因みに、シート名が苗字だけだったので
月報ブックL9の名前を参照したいと考えています。

■現時点でわからないところ
1.開いたブックのシートをループ処理する際の記載方法

2.月報ブックC46:D53(工事Noと工事名称)の、データがあるところまでをC3〜コピペする方法
 併せて月報ブックL9(名前)も同じ行までコピペする方法
(月報ブックの54行目には別のデータが入っています)

3.次シートの同じ作業を、2の最終行の次から行う方法

数時間かけてほんのさわりしかできませんでしたが、以下に(1)〜(4)を記載します。

 Sub 個人別一覧表作成()
 'シート追加

    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Range("B5") & Range("C5")
 '月報ファイルを開く
    Dim OpenFileName As String
    OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
    Workbooks.Open OpenFileName

また、本コメント中においてコードの文字サイズが変な箇所があると思うんですが
統一する方法はございますでしょうか。
(hana) 2021/01/27(水) 11:10


 >>また、本コメント中においてコードの文字サイズが変な箇所があると思うんですが 
>>統一する方法はございますでしょうか。
行の先頭を半角スペースにすると、スペースも認識され、細文字モードでみやすいですよ。連続している間効いています。

一行開けるともとに

 また半角スペースいれればいいですよ。
(隠居じーさん) 2021/01/27(水) 12:00

隠居じーさん様

ありがとうございます。
活用させていただきます。
(hana) 2021/01/27(水) 13:02


ループ処理の部分は、マクロの記録でコードを調べることが出来ないのでちょっと難しいかもしれませんね。

↓を【ステップ実行】してみて動きを確認したあと、判らない命令があればネット検索してみて、それでも判らなければどの部分がわからないか教えてください。

    Sub 個人別一覧表作成_改()
        Dim OpenFileName As String
        Dim dstSH As Worksheet, dstRNG As Range
        Dim srcWB As Workbook, srcRNG As Range
        Dim i As Long

        Stop 'ブレークポイントの代わり

        With ActiveSheet
            'シート追加(して変数にセット)
            Set dstSH = Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

            '(末尾に追加した)シートの名前を変更
            dstSH.Name = .Range("B5").Value & .Range("C5").Value

            Set dstRNG = dstSH.Range("C3")
        End With

        'ダイアログを表示して月報ファイルを選んでもらう
        OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")

        If OpenFileName = "False" Then
            'ファイルが選択されなかったら処理終了
            MsgBox "ファイルが選択されませんでした"
            Exit Sub
        Else
            '月報ファイルを開く(とともに、変数にセットする)
            Set srcWB = Workbooks.Open(OpenFileName)
        End If

        '【ループ処理】
        For i = 1 To srcWB.Worksheets.Count - 1
            With srcWB.Worksheets(i)
                Set srcRNG = .Range("C46", .Cells(.Cells(.Rows.Count, "C").End(xlUp).Row, "I"))
            End With

            dstRNG.Offset(, -2).Resize(srcRNG.Rows.Count).Value = srcWB.Worksheets(i).Name
            srcRNG.Copy dstRNG

            Set dstRNG = dstRNG.Offset(srcRNG.Rows.Count)
        Next i

        '■並び替え
        '■重複項目をクリア

    End Sub

(もこな2) 2021/01/27(水) 15:41


↑データが無いときに想定外の範囲がコピーされちゃうとおもうので、以下に訂正します。
(その他もちょい修正)
    Sub 個人別一覧表作成_改()
        Dim OpenFileName As String
        Dim MySH As Worksheet
        Dim dstSH As Worksheet, dstRNG As Range
        Dim srcWB As Workbook, srcRNG As Range
        Dim i As Long
        Dim 最終行 As Long

        Stop 'ブレークポイントの代わり

        Set MySH = ActiveSheet

        '▼-----ダイアログを表示して月報ファイルを選んでもらう-----
        OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
        If OpenFileName = "False" Then
            'ファイルが選択されなかったら処理終了
            MsgBox "ファイルが選択されませんでした"
            Exit Sub
        Else
            '月報ファイルを開く(とともに、変数にセットする)
            Set srcWB = Workbooks.Open(OpenFileName)
        End If
        '▲----------------------------------------------------------------

        '▼-----出力用のシートを準備-----------------------------------
        Set dstSH = Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        dstSH.Name = MySH.Range("B5").Value & MySH.Range("C5").Value
        Set dstRNG = dstSH.Range("C3")
        '▲----------------------------------------------------------------

        '▼-----【ループ処理】----------------------------------------------
        For i = 1 To srcWB.Worksheets.Count - 1
            With srcWB.Worksheets(i)
                最終行 = .Cells(.Rows.Count, "C").End(xlUp).Row
                If 最終行 > 45 Then
                    Set srcRNG = .Range("C46:I" & 最終行)
                    dstRNG.Offset(, -2).Resize(srcRNG.Rows.Count).Value = srcWB.Worksheets(i).Name
                    srcRNG.Copy dstRNG
                End If
            End With
        Next i
        '▲----------------------------------------------------------------

        '■稼働日数×7.5の計算
        '■並び替え
        '■重複項目をクリア
    End Sub

(もこな2) 2021/01/28(木) 08:05


もこな2様
本当にありがとうございます。
かなり時間がかかりましたが、概ね理解できました。

私が手を加えた点は
・出力用シートの準備を手前に持ってきました
(月報ファイルを開いた後だと、月報ファイル側で動作してしまいました。)
・ペーストを値にしました。
(元データが関数ということを伝え忘れていました。)
・ループ処理の最後に以下を追加しました。

   Set dstRNG = dstRNG.Offset(srcRNG.Rows.Count)

(昨日のコメントにあったものを流用しました。ここが一番勉強になりました。)

また、現状報告ですが
・C列が空白の行を削除する
という処理を、見よう見まねで追加してみました。

        '不要行削除
        Dim dlt As Long
        Dim toprow As Long
        Dim bottomrow As Long
        '開始する行
        toprow = 1
        '終了する行
        With dstSH
        bottomrow = .Cells(.Rows.Count, 3).End(xlUp).Row
        End With
        For dlt = bottomrow To toprow Step -1
        If dstSH.Range("C" & dlt) = "" Then
            'C列が空白なら行削除
        dstSH.Rows(dlt).Delete
        End If
    Next
殆どコピペのようなものですが、自分で書いたコードが動くのはうれしいですね。
改善点等ございましたらご教示ください。

また、調べてもわからない箇所が出てくるかと思いますので、頼らせてください。

(hana) 2021/01/28(木) 11:37


だいぶ経ってしまったので、もう見てないでしょうがコメントしておきます。
■1
>月報ファイル側で動作してしまいました
ちょっと意味がわかりませんが、出力用シートが月報ファイルに作成されたのでしょうか?

■2
>ペーストを値にしました。
どのようなアプローチにしたかわかりませんが出来たならOKですね。

■3
>ループ処理の最後に以下を追加しました。
失礼しました。整理したときにうっかり忘れました・・・

■4
>改善点等ございましたらご教示ください。
ご自身が理解できるのが一番だと思いますので現状でよろしいんじゃないでしょうか
効率面で考えるなら、空白セルを覚えておいてから、当該セルを【含む行】をまとめて削除するとか、そもそも空白はコピーしないとかアプローチがあるとおもいます。

■5
もし、話を続けるのであれば現状のコードを示されたほうが良いと思いますが、それはそれとして、元データが関数ならEndプロパティを使った方法だと最終行が正しく取得できませんので別アプローチにしたほうがよいですね。

    Sub 個人別一覧表作成_改二()
        Dim OpenFileName As String
        Dim MySH As Worksheet
        Dim dstSH As Worksheet, dstRNG As Range
        Dim srcWB As Workbook
        Dim i As Long
        Dim tmpRNG As Range

        Stop 'ブレークポイントの代わり
        Set MySH = ActiveSheet

        '▼-----ダイアログを表示して月報ファイルを選んでもらう-----
        OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
        If OpenFileName = "False" Then
            'ファイルが選択されなかったら処理終了
            MsgBox "ファイルが選択されませんでした"
            Exit Sub
        Else
            '月報ファイルを開く(とともに、変数にセットする)
            Set srcWB = Workbooks.Open(OpenFileName)
        End If
        '▲----------------------------------------------------------------

        '▼-----出力用のシートを準備-----------------------------------
        Set dstSH = Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        dstSH.Name = MySH.Range("B5").Value & MySH.Range("C5").Value
        Set dstRNG = dstSH.Range("C3")
        '▲----------------------------------------------------------------

        '▼-----【ループ処理】----------------------------------------------
        For i = 1 To srcWB.Worksheets.Count - 1
            With srcWB.Worksheets(i)
                Set tmpRNG = .Range("C46:C53").Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)

                If Not tmpRNG Is Nothing Then
                    With .Range("C46:I" & tmpRNG.Row)
                        dstRNG.Resize(.Rows.Count, .Columns.Count).Value = .Value
                        dstRNG.Offset(, -2).Resize(.Rows.Count).Value = .Parent.Name
                        Set dstRNG = dstRNG.Offset(.Rows.Count)
                    End With
                End If
            End With
        Next i
        '▲----------------------------------------------------------------

        '■稼働日数×7.5の計算
        '■並び替え
        '■重複項目をクリア
    End Sub

(もこな2 ) 2021/02/07(日) 18:11


もこな2様

コメントありがとうございます。
一つできるようになると、どんどんやりたいことが増えて
今も合間を見て当該マクロを作り上げています。

>ちょっと意味がわかりませんが、出力用シートが月報ファイルに作成されたのでしょうか?
→仰る通りです。説明がわかりにくくてすいません。

>ご自身が理解できるのが一番だと思いますので現状でよろしいんじゃないでしょうか
>効率面で考えるなら、空白セルを覚えておいてから、当該セルを【含む行】をまとめて削除するとか、そもそも空白はコピーしないとかアプローチがあるとおもいます。
→確かに、今は1行ずつ削除しにいっているので、まとめて削除できると更に効率的になります。
 ひとしきり完成したら、やってみようと思います。

>元データが関数ならEndプロパティを使った方法だと最終行が正しく取得できませんので別アプローチにしたほうがよいですね。
→そういった事もあるんですね、しっかり読み込んで組み込みます。

ほぼ知識0だった私に懇切丁寧に教えてくださり、本当にありがとうございました!
まだきっとこれからわからない箇所が出てくると思うので、その時は新たにスレッド(?)を建てようと思います。
(hana) 2021/02/08(月) 11:07


■6
出力用シートが月報ファイルに作成されたのは私のミスですね。ごめんなさい。
 誤 Set dstSH = Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
 正 Set dstSH = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

↑のようにブックを指定しなかったため、アクティブブックが対象になってました。

■7
>ひとしきり完成したら、やってみようと思います。
一つの方法として研究用のコードを提供します。

    Sub まとめて削除_研究用()
        Dim 行 As Long
        Dim 対象セル As Range
        Stop

        With ActiveSheet
            '▼ループ処理でC列を順番に見ていき「空白」のセルがあれば「対象セル」に追加して覚えていく
            For 行 = 1 To .Cells(.Rows.Count, "C").End(xlUp).Row
                If .Cells(行, "C").Value = "" Then
                    If 対象セル Is Nothing Then
                        Set 対象セル = .Cells(行, "C")
                    Else
                        Set 対象セル = Union(対象セル, .Cells(行, "C"))
                    End If
                End If
            Next

            '▼覚えたセルがあれば、当該セルを【含む行】を削除
            If Not 対象セル Is Nothing Then 対象セル.EntireRow.Delete
        End With
    End Sub

ほかにも、オートフィルタで空白行を抽出してから削除というアプローチもありそうですね。

(もこな2 ) 2021/02/09(火) 04:45


ご丁寧にありがとうございます。
Unionメソッドを使うと、複数セルを併せて参照することができるのですね!
早く作ってみたいです!

また、EntireRowに関しても初めて見ましたが、Rangeオブジェクトを返すんですね
実際に触ってみて、Rowとの違いを感じてみようと思います。

(hana) 2021/02/09(火) 15:22


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.