[[20170325225457]] 『「データを蓄積したい。」[初心者] について』(トランプ) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

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

投稿
[[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"

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

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


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

では、1行前の

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

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

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


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

こうすれば、1行だけでよいです。
 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


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.