DrunkBacchus

収穫記録に対応する播種記録を検索する

2007-02-18T00:17:56+09:00

播種記録を検索する関数 &html(

)
 Function FindSowData(StartDate As Date, _
                      Enddate As Date, _
                      Optional House As Variant = "", _
                      Optional Product As String = "", _
                      Optional Seed As String = "") As Variant
    '播種記録を検索する関数
    '引数
    '   検索開始期間
    '   検索終了期間
    '   ハウス          Option
    '   品目            Option
    '   品種            Option
    '
    '戻り値
    '   播種番号を配列で返す
    '   対応データがない場合Nothing
  
    Dim SrcBook As Workbook
    Dim SrcSheet As Worksheet
    Dim SrcData As Range
    Dim TempSheet As Worksheet
    Dim CriteriaA() As Variant
    Dim CriteriaR As Range
    Dim DistRange As Range
    Dim ResultArray As Variant
    
    
 '    Application.ScreenUpdating = False
    On Error GoTo err1
    '元データ範囲
    Set SrcData = Workbooks("播種記録2006.xls").Worksheets("播種記録").Range("$A$6:$N$239")
    '抽出用シートを用意
 '    Set TempSheet = Worksheets.Add
    Set TempSheet = Worksheets("Temp")
 
    'Criteria範囲を設定
    Set CriteriaR = TempSheet.Range("A1:E2")
    '抽出先範囲を設定
    Set DistRange = TempSheet.Range("A5")
    DistRange.Value = "番号"
    ReDim CriteriaA(1 To 2, 1 To 5)
    CriteriaA(1, 1) = "播種日" '開始日
    CriteriaA(1, 2) = "播種日" '終了日
    CriteriaA(1, 3) = "ハウス" '
    CriteriaA(1, 4) = "品目" '
    CriteriaA(1, 5) = "品種" '
    
    CriteriaA(2, 1) = ">=" & StartDate  '開始日
    CriteriaA(2, 2) = "<=" & Enddate    '終了日
    CriteriaA(2, 3) = House      '
    CriteriaA(2, 4) = Product    '
    CriteriaA(2, 5) = Seed       '
    CriteriaR = CriteriaA
 
    'Criteriaによる抽出
    On Error GoTo err2
    SrcData.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=CriteriaR, _
        CopyToRange:=DistRange, _
        Unique:=False
    
    Set DistRange = DistRange.CurrentRegion
    Set DistRange = DistRange.Offset(1, 0).Resize(DistRange.Rows.Count - 1, 1)
    Set ResultArray = DistRange
    
    '結果の行数をカウントする
    If ResultArray.Rows.Count > 1 Then
        FindSowData = ResultArray
    Else
        FindSowData = False
    End If
 
    GoTo WindUp
 err1:   '設定時のエラー
    MsgBox "設定時のエラー"
    FindSowData = False
    GoTo WindUp

 err2:   'フィルタ時のエラー
    MsgBox "フィルタ時のエラー"
    FindSowData = False
    GoTo WindUp

 WindUp: '後始末－終了
 myTimer3 = Timer
    CriteriaR.Clear
    DistRange.Clear
    On Error Resume Next
 '    Application.DisplayAlerts = False
 '    TempSheet.Delete
 '    Application.DisplayAlerts = True
    Set SrcBook = Nothing
    Set SrcSheet = Nothing
    Set SrcData = Nothing
    Set TempSheet = Nothing
    Set CriteriaR = Nothing
    Set DistRange = Nothing
    Set ResultArray = Nothing
 End Function
&html(

)

カレンダー枠作成

2007-02-18T00:10:59+09:00

'カレンダー枠の描画 Sub DrawCalendarFrame() Dim DateCol As Long Dim EndColumn As Long Dim ColumnWeekDay As Integer Dim ColumnMonth As Integer Dim ColumnDate As Date Dim RestDaysM As Integer '月の残り Dim RestDaysW As Integer '週の残り Dim ColumnDays As Integer '列の日数 'ラベル行の設定 Dim WeekRow As Long Dim MonthRow As Long Dim DateRow As Long Dim TopTitleRow As Long Dim ButtomTitleRow As Long 'セルに記入するラベル Dim MonthNo As Integer '結合するスタート列 Dim MonthCol As Long Dim WeekCol As Long '設定値の取得 StartDate = Range("C2").Value '開始日 EndDate = Range("C3").Value '終了日 StartColumn = Range("C4").Value '開始列 DayWidth = Range("C6").Value '日幅 StartDay = Range("C5").Value '開始曜日 ShipStartDate = Range("C8").Value '出荷開始日 WeekRow = 10 MonthRow = 11 DateRow = 12 TopTitleRow = Application.WorksheetFunction. _ Min(WeekRow, MonthRow, DateRow) ButtomTitleRow = Application.WorksheetFunction. _ Max(WeekRow, MonthRow, DateRow) '画面更新と警告の停止 Application.ScreenUpdating = False Application.DisplayAlerts = False '既存の枠をクリア EndColumn = Cells(DateRow, StartColumn). _ End(xlToRight).Column Range(Cells(TopTitleRow, StartColumn), _ Cells(ButtomTitleRow, EndColumn)).Clear ' スタート DateCol = StartColumn WeekCol = StartColumn MonthCol = StartColumn ColumnWeekDay = Weekday(StartDate) ColumnDate = StartDate '週番号を記入 Cells(WeekRow, DateCol).Value = _ Int((StartDate - ShipStartDate) / 7) + 1 '月番号を記入 MonthNo = Month(StartDate) Cells(MonthRow, DateCol).Value = MonthNo Do Until ColumnDate > EndDate 'Weekの残りを取得 RestDaysW = _ (StartDay - ColumnWeekDay + 6) Mod 7 + 1 '日付を記入 Cells(DateRow, DateCol).Value = ColumnDate '月の残り日数を取得 RestDaysM = DateSerial(Year(ColumnDate), _ Month(ColumnDate) + 1, 1) - ColumnDate '週のチェック 'もし､列の曜日が開始曜日と同じであれば If ColumnWeekDay = StartDay Then '週番号を記入 Cells(WeekRow, DateCol).Value = _ Int((ColumnDate - ShipStartDate) / 7) + 1 '結合スタート列に設定 WeekCol = DateCol '違えば Else '結合スタート列から現在列までを結合 Range(Cells(WeekRow, WeekCol), _ Cells(WeekRow, DateCol)).Merge End If '月のチェック 'もし､列の月がMonthNoと違っていれば If Month(ColumnDate) <> MonthNo Then '結合スタート列から､左隣の列までを結合 Range(Cells(MonthRow, MonthCol), _ Cells(MonthRow, DateCol - 1)).Merge '月番号を変更 MonthNo = Month(ColumnDate) '結合スタート月に設定 MonthCol = DateCol '月番号を記入 Cells(MonthRow, DateCol).Value = MonthNo End If 'もし､月残り日数の方が週残り日数よりも小さい場合は If RestDaysM < RestDaysW Then Columns(DateCol).ColumnWidth = _ pWidthToColumnWidth(RestDaysM * DayWidth) ColumnWeekDay = ColumnWeekDay + RestDaysM ColumnDate = ColumnDate + RestDaysM '何もなければ Else Columns(DateCol).ColumnWidth = _ pWidthToColumnWidth(RestDaysW * DayWidth) ColumnDate = ColumnDate + RestDaysW ColumnWeekDay = StartDay End If '次の列COL = col + 1 DateCol = DateCol + 1 Loop '追加整形 '最後の月をマージ Range(Cells(MonthRow, MonthCol), _ Cells(MonthRow, DateCol - 1)).Merge '最終列を取得 EndColumn = Cells(DateRow, StartColumn) _ .End(xlToRight).Column 'タイトル行の書式設定 Range(Cells(MonthRow, StartColumn), _ Cells(MonthRow, EndColumn)).HorizontalAlignment = xlCenter Range(Cells(WeekRow, StartColumn), _ Cells(WeekRow, EndColumn)).HorizontalAlignment = xlCenter Range(Cells(DateRow, StartColumn), _ Cells(DateRow, EndColumn)).HorizontalAlignment = xlLeft Range(Cells(DateRow, StartColumn), _ Cells(DateRow, EndColumn)).NumberFormatLocal = "d" Range(Cells(DateRow, StartColumn), _ Cells(DateRow, EndColumn)).ShrinkToFit = True Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

メニュー

2007-02-17T23:50:26+09:00

月ラベルと週ラベルのセルを結合する

2007-02-16T15:18:46+09:00

月ラベル、週ラベルセルの結合 MonthNo WeekNo MonthCol WeekCol 初期値設定 MonthNo=Month(StartDate) WeekNo= [[日付と週番号の関係]]

日付と週番号の関係

2007-02-16T15:13:39+09:00

[[Excel]]関数の場合　週番号=INT((日付-出荷開始日)/7)+1 　日付=出荷開始日+(週番号-1)*7

Excel

2007-01-31T14:47:58+09:00

*Excel 覚書 **栽培記録 -[[収穫記録に対応する播種記録を検索する]]

分布マップを作成する

2007-01-31T11:12:10+09:00

物件の所在地データを作成する

前準備
アドレスマッチングサービスの利用

=IF(IF(C1615=C1614,D1614+1,1)>C1615,1,IF(C1615=C1614,D1614+1,1))

更新履歴

2007-01-30T00:29:40+09:00

リンク

2007-01-27T23:52:49+09:00

農業

2006-09-18T04:00:38+09:00