[[20170325225457]]　『「データを蓄積したい。」[初心者]　について』（トランプ）　ページの最後に飛ぶ

『「データを蓄積したい。」[初心者]　について』（トランプ）

投稿
[[20170204150113]] 『データを蓄積したい。』（初心者）　
について...

以前、様々な方々にご指導頂いて、データを作成することができました。
このデータは、とても素晴らしいもので、色々な別のデータに活用させて頂いております。
そこで、一つご教授頂きたいことがあり、質問させて頂きます。
ここで作成したマクロのキーとなるのは「日付」ですが、このキーを「日付」＋「番号」にする場合、以下の部分の★★★部分に追加の構文が必要かと思うのですが、どのような構文が必要でしょうか。
ちなみに、上記投稿の中でのキー「日付」はB7セル、今回追加したいキー「番号」はB8セルに入っているものとします。

 Option Explicit

 Const sh1Name As String = "入出力"
 Const sh2Name As String = "DB"
 Const sh3Name As String = "転記"
 Const OneWay As String = "*"
 Sub Posting_Input()
 '入力後のデータをﾃﾞｰﾀﾍﾞｰｽに登録
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim v As Variant
    Dim row1 As Long
    Dim i As Long

    '変数の設定
    Set sh1 = Sheets(sh1Name)
    Set sh2 = Sheets(sh2Name)
    Set sh3 = Sheets(sh3Name)
    v = sh3.Range("A1").CurrentRegion.Value

    'データの存在チェック
★★★    If sh1.Range(v(2, 2)).Value = "" Then
        MsgBox "日付が未入力なのでﾃﾞｰﾀﾍﾞｰｽに登録できません。"
        Exit Sub
    End If
    If WorksheetFunction.CountIf(sh2.Range("A:A"), sh1.Range(v(2, 2))) Then
        If MsgBox("すでにﾃﾞｰﾀﾍﾞｰｽに登録されています。" & vbLf & "上書きしますか？", vbYesNo) = vbYes Then
            row1 = WorksheetFunction.Match(sh1.Range(v(2, 2)), sh2.Range("A:A"), 0)
        Else
            Exit Sub
        End If
    Else
        row1 = sh2.Range("B" & Rows.Count).End(xlUp).Row + 1
    End If

    'データの転記
    sh2.Unprotect "00001"
    For i = 2 To UBound(v, 1)
        sh2.Cells(row1, v(i, 3)).Value = sh1.Range(v(i, 2)).Value
    Next i
    sh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ReProtect sh2, "00001"

 End Sub
 Sub Posting_Output()
 'ﾃﾞｰﾀﾍﾞｰｽのデータを読込
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim v As Variant
    Dim row1 As Long
    Dim i As Long

    '変数の設定
    Set sh1 = Sheets(sh1Name)
    Set sh2 = Sheets(sh2Name)
    Set sh3 = Sheets(sh3Name)
    v = sh3.Range("A1").CurrentRegion.Value

    'データの存在チェック
    If sh1.Range(v(2, 2)).Value = "" Then
        MsgBox "日付が未入力なので読込できません。"
        Exit Sub
    End If
    If WorksheetFunction.CountIf(sh2.Range("A:A"), sh1.Range(v(2, 2))) Then
        row1 = WorksheetFunction.Match(sh1.Range(v(2, 2)), sh2.Range("A:A"), 0)
    Else
        MsgBox "該当の日付のデータがありません。"
        Exit Sub
    End If

    'データの転記
    For i = 2 To UBound(v, 1)
        If v(i, 4) <> OneWay Then
            sh1.Range(v(i, 2)).Value = sh2.Cells(row1, v(i, 3)).Value
        End If
    Next i

 End Sub
 Sub Data_Clear()
 '表示中データのクリア
    Dim sh1 As Worksheet
    Dim sh3 As Worksheet
    Dim v As Variant
    Dim i As Long

    '変数の設定
    Set sh1 = Sheets(sh1Name)
    Set sh3 = Sheets(sh3Name)
    v = sh3.Range("A1").CurrentRegion.Value

    'データのクリア
    For i = 2 To UBound(v, 1)
        If v(i, 4) <> OneWay Then
            sh1.Range(v(i, 2)).MergeArea.ClearContents
        End If
    Next i

 End Sub
 Sub ReProtect(sh As Worksheet, Optional pwd As String = "")
 '現在の保護要素を継承したシート再保護
    Dim pp As Protection
    Dim sv As Long

    With sh   '対象シート
        sv = .EnableSelection
        Set pp = .Protection

        .Protect Password:=pwd, Contents:=True, _
                    DrawingObjects:=Not .ProtectDrawingObjects, _
                    Scenarios:=Not .ProtectScenarios, _
                    AllowFormattingCells:=pp.AllowFormattingCells, _
                    AllowFormattingColumns:=pp.AllowFormattingColumns, _
                    AllowFormattingRows:=pp.AllowFormattingRows, _
                    AllowInsertingColumns:=pp.AllowInsertingColumns, _
                    AllowInsertingRows:=pp.AllowInsertingRows, _
                    AllowInsertingHyperlinks:=pp.AllowInsertingHyperlinks, _
                    AllowDeletingColumns:=pp.AllowDeletingColumns, _
                    AllowDeletingRows:=pp.AllowDeletingRows, _
                    AllowSorting:=pp.AllowSorting, _
                    AllowFiltering:=pp.AllowFiltering, _
                    AllowUsingPivotTables:=pp.AllowUsingPivotTables
        .EnableSelection = sv
    End With

 End Sub

ご教授よろしくお願いします。

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

回答ではありません。

＞ ReProtect sh2, "00001"

これ何のためにありますか。
パスワード設定なら、１行前で一緒に実行でよいです。
許可したい操作も、１行前でよいです。

（マナ） 2017/03/25(土) 23:35

DBシートも確認用として表示させておき、パスワードをかけて保護しておくものです。
改ざんされないようにです。あくまで確認用で。
以前、ご教授いただいたものです。
（トランプ） 2017/03/25(土) 23:41

では、１行前の

＞sh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

は何のためにありますか。

（マナ） 2017/03/25(土) 23:45

すみません。
構文をきちんと理解できていません。
申し訳ありません。
（トランプ） 2017/03/25(土) 23:51

こうすれば、１行だけでよいです。

 sh2.Protect Password:="00001", DrawingObjects:=True, Contents:=True, Scenarios:=True

本題と関係ないことで、お邪魔しました。

（マナ） 2017/03/25(土) 23:57

 To マナさん

 私が回答する立場ではありませんが、私が時折アップしている ReProtect が使われていますので。

 前トピで、シート保護の件について、ちょこっとコメントしました。

 sh2.Protect Password:="00001", DrawingObjects:=True, Contents:=True, Scenarios:=True

 これだけでは、シート保護条件として、ロックされたセル範囲の選択、ロックされていないセル範囲の選択　しか
 設定されないと理解しています。

 もともと設定されている条件が、これだけであればいいのですが、他の条件も許容して設定していたとすると
 その再現が必要になってきますね。

 もちろん、それら条件を明示的に Protectメソッドで指定すればいいわけですが、もしかしたら保護条件の追加変更などもあるかもしれない。

 ということで、『現在の条件を継承して保護』の話を（元トピで）しました。
 コードは提示していないのですが、トランプさんが、さがして使われたのかなと、そう思っています。

（β） 2017/03/26(日) 05:18

βさん、いつもありがとうございます。

はい、承知しています。
βさんが、解説してくださるだろうことも期待していました。

ただトランプさんが、どこまで理解されているかは？

何を許可するか（何をさせたくないか）は
トランプさんが決められる立場にあるのだから、
コードで指定すればよいだけの気がしますし、

仮に、保護条件の変更が必要になった場合、
（例えば、オートフィルタは許可したいとか）
どう修正したらよいかも、まだ理解できていないと思います。

なので、今のコードの中途半端な使い方になったのかなと。

トランプさんが、βさんのコメントを思い出し、
ReProtect を探し出してきて使ったのは、ちょっと意外でしたが
目的が、パスワードを設定したいということであれば
それは違うでしょうと思いコメントしました。

（マナ） 2017/03/26(日) 10:12

コメント返信：

[ 一覧(最新更新順) ]

[[20170325225457]] 『「データを蓄積したい。」[初心者] について』（トランプ） ページの最後に飛ぶ

[[20170325225457]]　『「データを蓄積したい。」[初心者]　について』（トランプ）　ページの最後に飛ぶ