エクセルにて作業スケジュールの管理を行いたいです。

エクセル表計算(無理なら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差し上げます】

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2011/05/16 19:20:56
  • 終了:2011/05/23 01:59:32

ベストアンサー

id:windofjuly No.4

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/17 04:00:35

ポイント100pt

配列を介さない方法を選択してみました

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
id:pochi1234

かなりいい感じです。配列を使わずオブジェクトでできるんですね。

いるか賞候補です。

あつかましいお願いですが、初歩的な質問に答えて頂ければ 500P + 1000P以上 差し上げます。


仕様は


・オーダー表

  No 受注日 管理番号 納期 作業1 ... 10

  B   C    D    E  F  ...  Q


  ↓


・スケジュール表

  No  管理番号 作業の種類   作業日

  A    B      C      D

  作業の種類には  作業1~10 のいずれかが入り

  作業日には    作業のセルにある日付


にできればと考えています。


合わせて 作業1 ~ 作業10の フォント色とセルの色をコピーできて 行にたいして貼り付けられればと

考えています。

よろしくお願い致します。

2011/05/19 07:19:29

その他の回答(3件)

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/16 21:45:02

ポイント100pt

関数だけで実行することも出来なくはなさそうですが複雑になりそうなのでクエリを提案

(VBAも便利なのですがクエリに慣れると色々便利なので・・・)

 

【1】クエリの使い方の確認と練習

xlsファイルは練習用にコピーしてから実施してください

手順は下記になります

http://www.eurus.dti.ne.jp/~yoneyama/Excel/filter2.htm

練習では丸ごとコピーになってます

 

【2】SQL

丸ごとコピーで使い方が判ってきたら、

(1)手順1から手順6までを行った続きの手順7で「MicrosoftQueryデータの表示またはクエリの編集を行う」を選択して下記のようなSQLに書き換えます

(2)MicrosoftQueryのウィンドウでは「SQL」というボタンをクリックして、次のように入力してOKします

(3)「SQLクエリを再表示できません。継続しますか?」と出てきたら気にせずOKをクリック

SELECT 作業1,管理番号,'作業1' FROM `Z:\Book1`.`Sheet1$` WHERE 作業1 > 0
UNION ALL
SELECT 作業2,管理番号,'作業2' FROM `Z:\Book1`.`Sheet1$` WHERE 作業2 > 0
UNION ALL
SELECT 作業3,管理番号,'作業3' FROM `Z:\Book1`.`Sheet1$` WHERE 作業3 > 0
UNION ALL
SELECT 作業4,管理番号,'作業4' FROM `Z:\Book1`.`Sheet1$` WHERE 作業4 > 0
UNION ALL
SELECT 作業5,管理番号,'作業5' FROM `Z:\Book1`.`Sheet1$` WHERE 作業5 > 0
UNION ALL
SELECT 作業6,管理番号,'作業6' FROM `Z:\Book1`.`Sheet1$` WHERE 作業6 > 0
UNION ALL
SELECT 作業7,管理番号,'作業7' FROM `Z:\Book1`.`Sheet1$` WHERE 作業7 > 0
UNION ALL
SELECT 作業8,管理番号,'作業8' FROM `Z:\Book1`.`Sheet1$` WHERE 作業8 > 0
UNION ALL
SELECT 作業9,管理番号,'作業9' FROM `Z:\Book1`.`Sheet1$` WHERE 作業9 > 0
UNION ALL
SELECT 作業10,管理番号,'作業10' FROM `Z:\Book1`.`Sheet1$` WHERE 作業10 > 0
ORDER BY 作業1

私の場合はZ:\Book1.xlsファイルのSheets1が元のデータなので上記のようになってます。実際のファイル名やシート名にあわせてください

(4)「ファイル」メニューから「MicrosaoftExcelにデータを返す」をクリックするとシートに反映されます

 

【3】注意点

オリジナルのデータを変更してもクエリの結果には反映されません

(右クリック「データを更新」などとすれば更新されます)

 

結果反映はVBAで自動的に処理させることもできます(下記一例)がデータ量によっては応答性が落ちる場合があります

 

クエリの結果を表示しているシートタブを右クリックしてコードを表示し

当該シートに下記のように記述すればシートを開く度に自動的にデータの更新を行ってくれます

Private Sub Worksheet_Activate()
    Range("A1").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
End Sub

 

補足必要でしたらコメント欄にて…

id:pochi1234

とても親切な回答ありがとうございます。しかし、客先に提出することもあるため、クエリがインストールされていないPCもあるため、使用するのが難しいです。

2次元配列を2つ使用して、ほしいデータへの変換はできたのですが、

別シートからの値の取得と、そのシートのへの貼り付け?がうまくできなくて困っていました。

Sub test()

Dim i As Long

Dim j As Long

Dim Data1(65536, 16) As String * 20

Dim Data2(65536, 4) As String * 20

Data1() = Worksheets("オーダー表").range("B14:Q50000")

For i = 0 To 65536

Data2(j, 0) = Data(i, 0)

Data2(j, l) = Data(i, 2)

Data2(j, 2) = Data(i, 5)

If Data1(i, 5) <> "" Then

Data2(j, 3) = "作業1"

j = j + 1

End If

Data2(j, 0) = Data(i, 0)

Data2(j, l) = Data(i, 2)

Data2(j, 2) = Data(i, 6)

If Data1(i, 6) <> "" Then

Data2(j, 3) = "作業2"

j = j + 1

End If

Next

ActiveSheet.Paste Destination:=Worksheets("スケジュール表") = Data2()

End Sub

2011/05/16 23:49:57
id:Banias No.2

Banias回答回数237ベストアンサー獲得回数192011/05/16 22:40:49

ピボットテーブルを使って集計してみてください。

id:pochi1234

ピボットテーブルではできなそうなのですが

2011/05/17 00:10:59
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912011/05/17 01:30:20

参考例は

1/1   A001 作業1

1/1   A001 作業2

1/2   A001 作業3

2/1   A002 作業1

2/1   A002 作業3

という解釈でよいでしょうか。


一応上記だと仮定してのマクロの例です。

Option Explicit

'// オーダー表シートの位置情報
Const ORDER_TITLE_ROW = 1  '// タイトル行
Const ORDER_ID_COL = "B"   '// 管理番号列

'// スケジュール表シートの位置情報
Const SCHEDULE_DATE_COL = "A"   '// 日付列
Const SCHEDULE_ID_COL = "B"     '// 管理番号列
Const SCHEDULE_WORK_COL = "C"   '// 作業の種類列


Sub MakeSchedule()
    '// オーダー表シート
    Dim orderWS As Worksheet
    Set orderWS = Worksheets("オーダー表")
    
    '// スケジュール表シート
    Dim scheduleWS As Worksheet
    Set scheduleWS = Worksheets("スケジュール表")
    
    Dim lastRow As Long
    lastRow = orderWS.Cells(Rows.Count, ORDER_ID_COL).End(xlUp).Row
        
    '// スケジュール表シートの初期化処理
    scheduleWS.Cells.ClearContents
    scheduleWS.Cells(1, SCHEDULE_DATE_COL).Value = "作業日"
    scheduleWS.Cells(1, SCHEDULE_ID_COL).Value = "管理番号"
    scheduleWS.Cells(1, SCHEDULE_WORK_COL).Value = "作業の種類"
    
    Dim r As Long
    Dim c As Long
    Dim dstRow As Long
    dstRow = 2
    For r = ORDER_TITLE_ROW + 1 To lastRow
        For c = Cells(ORDER_TITLE_ROW, ORDER_ID_COL).Column + 1 To Columns.Count
            If orderWS.Cells(ORDER_TITLE_ROW, c).Value <> "" And orderWS.Cells(r, c).Value <> "" Then
                scheduleWS.Cells(dstRow, SCHEDULE_DATE_COL).Value = orderWS.Cells(r, c).Value
                scheduleWS.Cells(dstRow, SCHEDULE_ID_COL).Value = orderWS.Cells(r, ORDER_ID_COL).Value
                scheduleWS.Cells(dstRow, SCHEDULE_WORK_COL).Value = orderWS.Cells(ORDER_TITLE_ROW, c).Value
                dstRow = dstRow + 1
            End If
        Next
    Next
End Sub

不明な点や仕様の誤解はコメントで対応しますので、

下記の「この質問・回答へのコメント」を有効にお願いします。

id:windofjuly No.4

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/17 04:00:35ここでベストアンサー

ポイント100pt

配列を介さない方法を選択してみました

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
id:pochi1234

かなりいい感じです。配列を使わずオブジェクトでできるんですね。

いるか賞候補です。

あつかましいお願いですが、初歩的な質問に答えて頂ければ 500P + 1000P以上 差し上げます。


仕様は


・オーダー表

  No 受注日 管理番号 納期 作業1 ... 10

  B   C    D    E  F  ...  Q


  ↓


・スケジュール表

  No  管理番号 作業の種類   作業日

  A    B      C      D

  作業の種類には  作業1~10 のいずれかが入り

  作業日には    作業のセルにある日付


にできればと考えています。


合わせて 作業1 ~ 作業10の フォント色とセルの色をコピーできて 行にたいして貼り付けられればと

考えています。

よろしくお願い致します。

2011/05/19 07:19:29
  • id:windofjuly
    うぃんど 2011/05/19 15:18:38
    オーダー表は引き続き13行目がタイトルで14行目以降がデータとしていますのでtitleRangeは必要に応じて変更が必要
    受注日と納期もtitleRangeに含まれていますが、これはVBAのRANGE指定の都合(間を飛ばして指定できない)です
    スケジュール表の並び順は前回同様にしてあります

    Option Explicit

    Sub test3()
    '画面更新停止
    '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:H13": '見出し行(NO,受注日,管理番号,納期,作業1以降の順)

    '出力先シートの全面クリアと見出し行作成
    sheetB.Select
    With Cells
    .ClearContents
    .Interior.ColorIndex = xlNone
    .Font.ColorIndex = 0
    End With
    Range("A1:D1") = Array("No", "管理番号", "作業の種類", "作業日")

    'コピー
    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 = 5 To headLineCount
    '「No」コピーと貼り付け
    .Range(.Cells(startRow, headLine(1).Column), .Cells(lastRow, headLine(1).Column)).Copy
    Cells(pasteRow, "A").Select
    ActiveSheet.Paste
    '「管理番号」コピーと貼り付け
    .Range(.Cells(startRow, headLine(3).Column), .Cells(lastRow, headLine(3).Column)).Copy
    Cells(pasteRow, "B").Select
    ActiveSheet.Paste
    '「作業の種類」貼り付け
    Range(Cells(pasteRow, "C"), Cells(pasteRow + dataRows - 1, "C")).Value = headLine(i).Value
    '「作業日」コピーと貼り付け
    .Range(.Cells(startRow, headLine(i).Column), .Cells(lastRow, headLine(i).Column)).Copy
    Cells(pasteRow, "D").Select
    ActiveSheet.Paste
    '色づけ
    With Range(Cells(pasteRow, "A"), Cells((pasteRow + dataRows - 1), "D"))
    .Font.Color = headLine(i).Font.Color: '文字色
    .Interior.Color = headLine(i).Interior.Color: '背景色
    .Interior.Pattern = headLine(i).Interior.Pattern: '背景パターン
    End With
    pasteRow = pasteRow + dataRows
    Next i
    Application.CutCopyMode = False
    End With

    'ソート (優先順位は1:作業日、2:管理番号、3:作業種別)
    Columns("A:D").Select
    Selection.Sort Key1:=Range("D2"), 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("D:D").Find("-"): ' -を検索
    If lastCell Is Nothing Then ' - が見当たらなかった場合
    Range(Cells(Columns("D:D").SpecialCells(xlCellTypeBlanks).Row, 1), Range("D1").SpecialCells(xlLastCell)).Delete
    Else ' - が見つかった場合
    Range(Cells(lastCell.Row, 1), Range("D1").SpecialCells(xlLastCell)).Delete
    End If

    '画面更新開始
    Application.ScreenUpdating = True
    End Sub
  • id:pochi1234
    ご回答ありがとうございました。
    ポイントは付けれなかった分を別に送信させて頂きました。
  • id:windofjuly
    うぃんど 2011/05/23 10:10:00
    ポイント付きメッセージ確かに頂戴いたしました
    ありがとうございます

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません