[[20110127180056]]　『飲食店の予約表』（みーたん）　ページの最後に飛ぶ

『飲食店の予約表』（みーたん）

飲食店の予約表をつくってるのですが、シート1に年間のカレンダーがあり、シート２に月の予約表を縦に1日から入力してるのですが、カレンダーの日付をクリックするとその日の予約表を表示させたいのです。ハイパーリンクをつかってする方法を思いつきましたが、月ごとにシートをつくるのでかなり時間がかかります。何かいい方法がありますか？初心者なのでよろしくおねがいします。

 リハビリの為、ちょっと作ってみましたｂ
　
 まっさらなシートを用意していただき、下記コードを標準モジュールへ貼り付けて実行してみてください。
　
 標準モジュールへ
'------------------
Sub TEST()
Dim i As Integer, j As Integer, x As Integer, y As Integer
Dim xx As Integer, yy As Integer, MyY As Integer, Nissu As Integer
    Application.ScreenUpdating = False
    MyY = Application.InputBox("西暦で年を入力してください" & vbCrLf & "例 ： 2011", "年度入力", 2011, , , , , Type:=1)
    With ActiveSheet
        For i = 1 To 12
            Nissu = Day(DateSerial(MyY, i + 1, 0))
            With Sheets.Add(After:=Worksheets(Worksheets.Count))
                .Name = MyY & "年" & i & "月"
                .Range("A1").Value = .Name & "予約表"
                .Range("A3").Value = DateSerial(MyY, i, 1)
                .Range("B3").Value = "=TEXT(A3,""aaa"")"
                .Range("A3:B3").AutoFill Destination:=.Range("A3:B3").Resize(Nissu), Type:=xlFillValues
                .Columns("A:A").NumberFormatLocal = "d"
            End With
            x = IIf(i Mod 2 = 0, 9, 1)
            y = ((Int((i - 1) / 2)) * 9) + 1
            .Cells(y, x + 4) = CStr(i) & "月"
            .Cells(y + 2, x + 1).Resize(, 7) = Array("日", "月", "火", "水", "木", "金", "土")
            .Cells(y + 2, x + 1).Font.ColorIndex = 3
            .Cells(y + 2, x + 7).Font.ColorIndex = 5
            xx = Weekday(DateSerial(MyY, i, 1)) - 1
            yy = 3
            For j = 1 To Nissu
                xx = xx + 1
                If xx = 8 Then
                    xx = 1
                    yy = yy + 1
                End If
                .Cells(y + yy, x + xx) = "=HYPERLINK(""#'" & MyY & "年" & i & "月'!A" & 2 + j & """," & j & ")" '日を書く
                Select Case xx
                    Case 1: .Cells(y + yy, x + xx).Font.ColorIndex = 3
                    Case 7: .Cells(y + yy, x + xx).Font.ColorIndex = 5
                    Case Else: .Cells(y + yy, x + xx).Font.ColorIndex = 1
                End Select
            Next j
        Next i
        .Cells.ColumnWidth = 3
        .Select
    End With
    Application.ScreenUpdating = True
End Sub
　
'----------------------
　
 手順
１．新規シートを準備
２．Microsoft Visual Basic を開く
　　ツール → マクロ → Visual Basic Editor
　　または
　　Alt + 【F11】
３．出てきた画面より「標準モジュール」を出す
　　挿入 → 標準モジュール
４．上記で出した白い画面に、上記コードをコピペ
５．【×】で、その画面を閉じる
６．ツール → マクロ → マクロ
　　または
　　Alt + 【F8】
７．TEST を選らんで【実行】

 以上です。
 ここ1年以上、エクセルに携わっていなかったため、ちょっと的外れの可能性もあります・・・
　
 （キリキ）（〃⌒o⌒)b

キリキさん、大変丁寧にありがとうございます。
ひとつお聞きしたいのですが、予定表の１日のだいたい１０件ぐらい予約があるので
行数を増やしたいのですがどうすればよいのでしょうか？
（みーたん）

 予約件数がまちまちなのでしたら、縦ではなく横でするのはどうでしょう？
　
'------------------
Sub TEST()
Dim i As Integer, j As Integer, x As Integer, y As Integer
Dim xx As Integer, yy As Integer, MyY As Integer, Nissu As Integer
    Application.ScreenUpdating = False
    MyY = Application.InputBox("西暦で年を入力してください" & vbCrLf & "例 ： 2011", "年度入力", 2011, , , , , Type:=1)
    With ActiveSheet
        For i = 1 To 12
            Nissu = Day(DateSerial(MyY, i + 1, 0))
            With Sheets.Add(After:=Worksheets(Worksheets.Count))
                .Name = MyY & "年" & i & "月"
                .Range("A1").Value = .Name & "予約表"
                .Range("A3").Value = DateSerial(MyY, i, 1)
                .Range("A4").Value = "=TEXT(A3,""aaa"")"
                .Range("A3:A4").AutoFill Destination:=.Range("A3:A4").Resize(, Nissu), Type:=xlFillValues
                .Rows("3:3").NumberFormatLocal = "d"
            End With
            x = IIf(i Mod 2 = 0, 9, 1)
            y = ((Int((i - 1) / 2)) * 9) + 1
            .Cells(y, x + 4) = CStr(i) & "月"
            .Cells(y + 2, x + 1).Resize(, 7) = Array("日", "月", "火", "水", "木", "金", "土")
            .Cells(y + 2, x + 1).Font.ColorIndex = 3
            .Cells(y + 2, x + 7).Font.ColorIndex = 5
            xx = Weekday(DateSerial(MyY, i, 1)) - 1
            yy = 3
            For j = 1 To Nissu
                xx = xx + 1
                If xx = 8 Then
                    xx = 1
                    yy = yy + 1
                End If
                .Cells(y + yy, x + xx) = "=HYPERLINK(""#'" & MyY & "年" & i & "月'!" & Cells(3, j).Address(0, 0) & """," & j & ")"
                Select Case xx
                    Case 1: .Cells(y + yy, x + xx).Font.ColorIndex = 3
                    Case 7: .Cells(y + yy, x + xx).Font.ColorIndex = 5
                    Case Else: .Cells(y + yy, x + xx).Font.ColorIndex = 1
                End Select
            Next j
        Next i
        .Cells.ColumnWidth = 3
        .Select
    End With
    Application.ScreenUpdating = True
End Sub
　
 （キリキ）（〃⌒o⌒)b

キリキさん、ありがとうございます。
セルに人数、名前、電話番号など9項目の枠が必要なので入力するとずれてしまいます。
いつも１０件ぐらいの予約は、あるので縦に１０行おきに日付入力することは、
可能でしょうか？？本当に何回もすみません。
（みーたん）

 こんな感じで対応出来そうでしょうか？
　
Sub TEST()
Dim i As Integer, j As Integer, x As Integer, y As Integer, n As Integer
Dim xx As Integer, yy As Integer, MyY As Integer, Nissu As Integer
Dim MyA() As Variant
    Application.ScreenUpdating = False
    MyY = Application.InputBox("西暦で年を入力してください" & vbCrLf & "例 ： 2011", "年度入力", 2011, , , , , Type:=1)
    With ActiveSheet
        For i = 1 To 12
            Nissu = Day(DateSerial(MyY, i + 1, 0))
            With Sheets.Add(After:=Worksheets(Worksheets.Count))
                .Name = MyY & "年" & i & "月"
                ReDim MyA(1 To Nissu * 11, 1 To 2)
                .Range("A1").Value = .Name & "予約表"
                .Range("A3").Resize(, 11) = [{"日付","曜日","名前","電話番号","人数","項目１","項目２","項目３","項目４","項目５","項目６"}]
                For n = 1 To Nissu
                    MyA(n + ((n - 1) * 10), 1) = DateSerial(MyY, i, n)
                    MyA(n + ((n - 1) * 10), 2) = Format(MyA(n + ((n - 1) * 10), 1), "aaa")
                Next n
                .Range("A4").Resize(UBound(MyA, 1), 2) = MyA()
                .Columns("A:A").NumberFormatLocal = "d"
                .Range("A3").Resize(UBound(MyA, 1) + 1, 11).Borders.LineStyle = True
                Erase MyA
            End With
            x = IIf(i Mod 2 = 0, 9, 1)
            y = ((Int((i - 1) / 2)) * 9) + 1
            .Cells(y, x + 4) = CStr(i) & "月"
            .Cells(y + 2, x + 1).Resize(, 7) = Array("日", "月", "火", "水", "木", "金", "土")
            .Cells(y + 2, x + 1).Font.ColorIndex = 3
            .Cells(y + 2, x + 7).Font.ColorIndex = 5
            xx = Weekday(DateSerial(MyY, i, 1)) - 1
            yy = 3
            For j = 1 To Nissu
                xx = xx + 1
                If xx = 8 Then
                    xx = 1
                    yy = yy + 1
                End If
                .Cells(y + yy, x + xx) = "=HYPERLINK(""#'" & MyY & "年" & i & "月'!A" & 3 + j + ((j - 1) * 10) & """," & j & ")"
                Select Case xx
                    Case 1: .Cells(y + yy, x + xx).Font.ColorIndex = 3
                    Case 7: .Cells(y + yy, x + xx).Font.ColorIndex = 5
                    Case Else: .Cells(y + yy, x + xx).Font.ColorIndex = 1
                End Select
            Next j
        Next i
        .Cells.ColumnWidth = 3
        .Select
    End With
    Application.ScreenUpdating = True
End Sub
　
 順番や項目の変更は下記の "？？？" の部分を変更してください。
 >.Range("A3").Resize(, 11) = [{"日付","曜日","名前","電話番号","人数","項目１","項目２","項目３","項目４","項目５","項目６"}]
　　
 （キリキ）（〃⌒o⌒)b

キリキさん、ありがとうございます。希望通りの表が出来つつあります。
わがままついでにもうひとつ質問なんですが、月のセルの日付を４/１と
表記したいのですが…。何回もすいません。
（みーたん）

 携帯からなので外してたらごめんなさい。。。

 ここを
 >                .Columns("A:A").NumberFormatLocal = "d"
 こんな感じに変えるとどうしますか？
                 .Columns("A:A").NumberFormatLocal = "m/d"

 (キリキ)（〃⌒o⌒)b

キリキさん、ありがとうございます。早速変えてみましたが1/1/2011のままでした。
（みーたん）

 >早速変えてみましたが1/1/2011のままでした。
 1/1/2011　ですか？？？
　
 こちらで試しましたが、大丈夫だったんですけど。。。
　
 もう一度、下記で試してみてくださいb
　
Sub TEST()
Dim i As Integer, j As Integer, x As Integer, y As Integer, n As Integer
Dim xx As Integer, yy As Integer, MyY As Integer, Nissu As Integer
Dim MyA() As Variant
    Application.ScreenUpdating = False
    MyY = Application.InputBox("西暦で年を入力してください" & vbCrLf & "例 ： 2011", "年度入力", 2011, , , , , Type:=1)
    With ActiveSheet
        For i = 1 To 12
            Nissu = Day(DateSerial(MyY, i + 1, 0))
            With Sheets.Add(After:=Worksheets(Worksheets.Count))
                .Name = MyY & "年" & i & "月"
                ReDim MyA(1 To Nissu * 11, 1 To 2)
                .Range("A1").Value = .Name & "予約表"
                .Range("A3").Resize(, 11) = [{"日付","曜日","名前","電話番号","人数","項目１","項目２","項目３","項目４","項目５","項目６"}]
                For n = 1 To Nissu
                    MyA(n + ((n - 1) * 10), 1) = DateSerial(MyY, i, n)
                    MyA(n + ((n - 1) * 10), 2) = Format(MyA(n + ((n - 1) * 10), 1), "aaa")
                Next n
                .Range("A4").Resize(UBound(MyA, 1), 2) = MyA()
                .Columns("A:A").NumberFormatLocal = "m/d"
                .Range("A3").Resize(UBound(MyA, 1) + 1, 11).Borders.LineStyle = True
                Erase MyA
            End With
            x = IIf(i Mod 2 = 0, 9, 1)
            y = ((Int((i - 1) / 2)) * 9) + 1
            .Cells(y, x + 4) = CStr(i) & "月"
            .Cells(y + 2, x + 1).Resize(, 7) = Array("日", "月", "火", "水", "木", "金", "土")
            .Cells(y + 2, x + 1).Font.ColorIndex = 3
            .Cells(y + 2, x + 7).Font.ColorIndex = 5
            xx = Weekday(DateSerial(MyY, i, 1)) - 1
            yy = 3
            For j = 1 To Nissu
                xx = xx + 1
                If xx = 8 Then
                    xx = 1
                    yy = yy + 1
                End If
                .Cells(y + yy, x + xx) = "=HYPERLINK(""#'" & MyY & "年" & i & "月'!A" & 3 + j + ((j - 1) * 10) & """," & j & ")"
                Select Case xx
                    Case 1: .Cells(y + yy, x + xx).Font.ColorIndex = 3
                    Case 7: .Cells(y + yy, x + xx).Font.ColorIndex = 5
                    Case Else: .Cells(y + yy, x + xx).Font.ColorIndex = 1
                End Select
            Next j
        Next i
        .Cells.ColumnWidth = 3
        .Select
    End With
    Application.ScreenUpdating = True
End Sub
　
 だめだったらごめんね＾＾；
　
 （キリキ）（〃⌒o⌒)b

キリキさん、違うパソコンで試したら出来ました。
お手数おかけしました。想像通りの表になりました。
ありがとうございました。
（みーたん）

 ＞早速変えてみましたが1/1/2011のままでした。
 こんな時は、Value2です。

 .Range("A4").Resize(UBound(MyA, 1), 2) = MyA()
 　↓
 .Range("A4").Resize(UBound(MyA, 1), 2).Value2 = MyA()
                                       ~~~~~~~

 (HANA)

 HANAさん、フォローありがとうっすb

 やっぱり、いろんな事が頭から抜けてますね。。。
 時間が無くても、少し触ってないとダメだなぁ

 と、言うことで、みーたんさん追加しておいてくださいね～♪

 (キリキ)（〃⌒o⌒)b

コメント返信：

[ 一覧(最新更新順) ]

[[20110127180056]] 『飲食店の予約表』（みーたん） ページの最後に飛ぶ

[[20110127180056]]　『飲食店の予約表』（みーたん）　ページの最後に飛ぶ