[[20100107165603]]　『締めと支払』（DAN）　ページの最後に飛ぶ

『締めと支払』（DAN）

 取引先と20締め翌月20支払の契約になっているのですが
 相手側がドルでの取引のため通常の会計ソフトが使用できません。
 下記のような事はできますでしょうか？ご教授お願いいたします。

 Sheet1
 A1      B1       C1      D1      
 契約No　IV No.　Cost　　SHIP DAY
 0001    02-001  USD10000  2009/12/18
 0001    02-001  USD30000  2009/12/21
 0001    02-001  USD5000   2010/01/11

 sheet2
 A1      B1       C1      D1 
 日付　　2010    01     
 契約No　IV No.　Cost　　SHIP DAY
 0001    02-001  USD30000  2009/12/21
 0001    02-001  USD5000   2010/01/11

 上記のようにシート１に伝票入力をし
 シート２に年と月を入れれば2009/12/21～2010/01/20までの
 伝票だけがでてきて一覧で出せる様にしたいと思います。

 またもし可能であればシート2の一覧をプリントアウトすれば
 シート1のE列にプリントアウトした行は「済」と入力されれば最高です。

 マクロ・関数どちらでも結構です。
 よろしくお願いいたします。
 Ver.2007   OS:Vista

 マクロです
＼Sheet1／シートタブを右クリック→コードの表示 下記コートをコペピ

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lstR As Long
If Target.Address(0, 0) <> "E1" Then Exit Sub
If MsgBox("表示行を印刷してE列に済をマークします", vbOKCancel) = vbCancel Then Exit Sub
lstR = Cells(Rows.Count, "D").End(xlUp).Row
Range("D2:D" & lstR).SpecialCells(xlCellTypeVisible).Offset(0, 1).Value = "済"
Range("A1:D" & lstR).PrintPreview
End Sub

 シート1 にオートフィルタを設定→D列▼オプション→抽出条件を2009/12/21以上、2010/01/20以下に設定→OKボタン
マクロはシート1のE1をダブルクリックで動きます
シート2は使いません
（エナン大好き）

 DANさん　こんばんは！
少し時間があったので作ってみました。
簡単に説明を入れていますので応用して頂けると幸いです。
「済」の扱いがよくわからないので印刷したのもだけに入る様にしています。
後のフォローが出来るかどうかわかりませんが、もしも出来なかったらお許しください。
Sheet2のコードモジュールに貼り付けます。
久々に書いたので、ちょっと自信ないです。間違っていたらごめんちゃいです。
一応、動作確認はしています。
では、では、また
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyDateA As Date
Dim MyDateB As Date
Dim MyAry() As Variant
Dim MyA As Variant
Dim i As Long
Dim j As Long
Dim k As Long
'複数選択を不可
If Target.Count > 1 Then Exit Sub
'Targetが"B1:C1"にあるか判定
If Intersect(Target, Range("B1:C1")) Is Nothing Then Exit Sub
'両方が数値であるか判定
If Application.Count(Range("B1:C1")) <> 2 Then Exit Sub
'MyDateAで当月の20日締めを作成
MyDateA = DateSerial(Range("B1").Value, Range("C1").Value, 20)
'日付と判定出来なければExit
If Not IsDate(MyDateA) Then
    MsgBox "日付と認識出来ません......"
    Exit Sub
Else '日付と判定されれば先月の21日をMyDateBに格納
    MyDateB = DateSerial(Range("B1").Value, Range("C1").Value - 1, 21)
End If
'Sheet1のデータをMyAに取得
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 4).Value
    '済を格納するために二次元方向へ拡張
    ReDim Preserve MyA(1 To UBound(MyA, 1), 1 To UBound(MyA, 2) + 1)
End With
'MyAの一元上限までループ
For i = 1 To UBound(MyA, 1)
    'SHIPDAYが先月の21日以上で且つ当月の20日以下かを判定
    If MyA(i, 4) >= MyDateB And MyA(i, 4) <= MyDateA Then
        '変数kをインクリメント
        k = k + 1
        '配列MyAryを拡張
        ReDim Preserve MyAry(1 To 4, 1 To k)
        'MyAryの一次元上限までへループ
        For j = 1 To UBound(MyAry, 1)
            'MyAryにMyAを代入
            MyAry(j, k) = MyA(i, j)
        Next
        '抽出結果を代入
        MyA(i, UBound(MyA, 2)) = "済"
    End If
Next
'イベントを停止
Application.EnableEvents = False
    With Range("A1")
        '抽出先を一行下げてクリア
        .CurrentRegion.Offset(1).ClearContents
        '抽出されたものがあればMyAryの行列を入れ替えて出力
        If k > 0 Then
            .Offset(1).Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry)
            If vbYes = MsgBox(k & "　件のデータが抽出されました" & vbCrLf & _
                "印刷しますか？", vbYesNo) Then
                '取りあえずプレビュー
                Me.PrintPreview
                With Sheets("Sheet1")
                    'Sheet1をクリア
                    .Cells.ClearContents
                    '済の入ったMyAを出力
                    .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
                End With
            End If
        Else
            MsgBox MyDateB & "　～　" & MyDateA & "　に該当するデータはありません................."
        End If
    End With
'イベントを解除
Application.EnableEvents = True
Erase MyAry, MyA
End Sub
(SoulMan）

 お返事遅くなり申し訳ございません。
 分かりやすい解説付きで本当にありがとうございます。
 後は何とか自力でアレンジしてみます。
 本当に助かりました。ありがとうございました。
 (DAN)

コメント返信：

[ 一覧(最新更新順) ]

[[20100107165603]] 『締めと支払』（DAN） ページの最後に飛ぶ

[[20100107165603]]　『締めと支払』（DAN）　ページの最後に飛ぶ