質問: エクセルにて作業スケジュールの管理を行いたいです。 エクセル表計算(無理ならVBAで)で作成しようと考えています。 良い方法が見つからなくて困っています。 どなたか良い案があればお願いします。 1つのエクセルファイルに オーダー表と、作業スケジュールの2シートがあります ■オーダー表 NO 管理番号 作業1 作業2 作業3 ....... 作業10 1 A001 1/1 1/2 1/2 2 A002 2/1 - 2/1 ■今回作成するスケジュール表 作業日 管理番号 作業の種類 1/1 A001 作業1 1/1 A001 作業2 1/2 A001 作業3 2/1 B001 作業1 2/1 B001 作業2 できれば並び替えせずに行いたいことと、作業のない部分は表示したくないないです。 例えば100*100マスを検索するとして、ブランクがあればどう処理するかについて悩んでいることと、 値が存在しなければ次へ進むような処理はエクセルの関数では難しいでしょうか? よろしくお願いします。 【いるか賞の方へ500P差し上げます】
回答: 配列を介さない方法を選択してみました A13からQ13までに「NO 管理番号 作業1 作業2 作業3 ....... 作業10」という見出しがあって14行目からデータがあるという想定にしてありますので、違う場合は"B13:Q13"を適宜修正してください 画面更新停止のコメントを外すのは動作確認出来てからにしてください ``` Option Explicit Sub test2() '画面更新停止 'Application.ScreenUpdating = False '準備 Dim sheetA As Worksheet Dim sheetB As Worksheet Dim titleRange As String Dim startRow As Long Dim lastRow As Long Dim dataRows As Long Dim headLine As Range Dim headLineCount As Long Dim pasteRow As Long Dim lastCell As Range Dim i As Long '指定 Set sheetA = Worksheets("オーダー表"): '読み込むシート Set sheetB = Worksheets("スケジュール表"): '書き出すシート titleRange = "B13:Q13": '見出し行(左端の行が管理番号となるように指定すること) '出力先シートの全面クリアと見出し行作成 sheetB.Select Cells.ClearContents Range("A1:C1") = Array("作業日", "管理番号", "作業の種類") 'コピー With sheetA Set headLine = .Range(titleRange) startRow = headLine(1).Row + 1: 'データ開始行 lastRow = .Cells(.Rows.Count, headLine(1).Column).End(xlUp).Row: '最終行 dataRows = lastRow - startRow + 1: 'データ件数 headLineCount = headLine.Count: '見出し数 pasteRow = 2: ' 書き出し位置 For i = 2 To headLineCount .Range(.Cells(startRow, headLine(i).Column), .Cells(lastRow, headLine(i).Column)).Copy Cells(pasteRow, "A").Select ActiveSheet.Paste .Range(.Cells(startRow, headLine(1).Column), .Cells(lastRow, headLine(1).Column)).Copy Cells(pasteRow, "B").Select ActiveSheet.Paste Range(Cells(pasteRow, "C"), Cells(pasteRow + dataRows - 1, "C")).Value = headLine(i).Value pasteRow = pasteRow + dataRows Next i Application.CutCopyMode = False End With 'ソート (優先順位は1:作業日、2:管理番号、3:作業種別) Columns("A:C").Select Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _ , Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin '不要部分削除 Set lastCell = Columns("A:A").Find("-"): ' -を検索 If lastCell Is Nothing Then ' - が見当たらなかった場合 Range(Cells(Columns("A:A").SpecialCells(xlCellTypeBlanks).Row, 1), Range("A1").SpecialCells(xlLastCell)).Delete Else ' - が見つかった場合 Range(Cells(lastCell.Row, 1), Range("A1").SpecialCells(xlLastCell)).Delete End If '画面更新開始 Application.ScreenUpdating = True End Sub ```