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

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

 

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

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

お尋ねいたします。
以前、ご教授いただいたこのデータがすばらしく、色々なデータに活用させていただいておりますが、この内容をもとに以下のような転記をさせます。

項目名 所定様式 DB
日付 B6 A
交番1 B13 B
交番2 B14 C
車輌 G13 D
乗務員 O13 E
始業 W13 F
出勤 AE13 G
出庫 AE14 H
確認1 AJ13 I
確認2 AL13 J
確認3 AN13 K
確認4 AP13 L
確認5 AR13 M
確認6 AT13 N
確認7 AV13 O
確認8 AX13 P
確認9 AZ13 Q
確認10 BB13 R
確認11 BD13 S
入庫1 BF13 T
入庫2 BF14 U
終業1 BK13 V
終業2 BK14 W
交番1 B15 X
交番2 B16 Y
車輌 G15 Z
乗務員 O15 AA
始業 W15 AB
出勤 AE15 AC
出庫 AE16 AD
確認1 AJ15 AE
確認2 AL15 AF
確認3 AN15 AG
確認4 AP15 AH
確認5 AR15 AI
確認6 AT15 AJ
確認7 AV15 AK
確認8 AX15 AL
確認9 AZ15 AM
確認10 BB15 AN
確認11 BD15 AO
入庫1 BF15 AP
入庫2 BF16 AQ
終業1 BK15 AR
終業2 BK16 AS
交番1 B17 AT
交番2 B18 AU
車輌 G17 AV
乗務員 O17 AW
始業 W17 AX
出勤 AE17 AY
出庫 AE18 AZ
確認1 AJ17 BA
確認2 AL17 BB
確認3 AN17 BC
確認4 AP17 BD
確認5 AR17 BE
確認6 AT17 BF
確認7 AV17 BG
確認8 AX17 BH
確認9 AZ17 BI
確認10 BB17 BJ
確認11 BD17 BK
入庫1 BF17 BL
入庫2 BF18 BM
終業1 BK17 BN
終業2 BK18 BO

上記を以下のように転記させることは可能なのでしょうか?
ご教授のほど、よろしくお願いします。

項目名 所定様式 DB
日付 B6 A
交番1 B13 B15 B17 B
交番2 B14 B16 B18 C
車輌 G13 G15 G17 D
乗務員 O13 O15 O17 E
始業 W13 W15 W17 F
出勤 AE13 AE15 AE17 G
出庫 AE14 AE16 AE18 H
確認1 AJ13 AJ15 AJ17 I
確認2 AL13 AL15 AL17 J
確認3 AN13 AN15 AN17 K
確認4 AP13 AP15 AP17 L
確認5 AR13 AR15 AR17 M
確認6 AT13 AT15 AT17 N
確認7 AV13 AV15 AV17 O
確認8 AX13 AX15 AX17 P
確認9 AZ13 AZ15 AZ17 Q
確認10 BB13 BB15 BB17 R
確認11 BD13 BD15 BD17 S
入庫1 BF13 BF15 BF17 T
入庫2 BF14 BF16 BF18 U
終業1 BK13 BK15 BK17 V
終業2 BK14 BK16 BK18 W

< 使用 Excel:Excel2013、使用 OS:Windows7 >


Sub main()
    Dim dic1, dic2, c As Range
    ActiveSheet.Copy after:=ActiveSheet
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    For Each c In ActiveSheet.Range("A:A").SpecialCells(xlCellTypeConstants)
        dic1(c.Value) = Trim(dic1(c.Value) & Space(1) & c.Offset(, 1).Value)
        If dic2(c.Value) = Empty Then dic2(c.Value) = c.Offset(, 2).Value
    Next c
    ActiveSheet.Cells.ClearContents
    ActiveSheet.Range("A1").Resize(dic1.Count, 3) = WorksheetFunction.Transpose(Array(dic1.keys, dic1.items, dic2.items))
End Sub
(mm) 2017/05/18(木) 09:54

mmさん、ありがとうございます。
これは、以下のコードのどこに組み込めばよいでしょうか?

 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

(トランプ) 2017/05/18(木) 20:01


お邪魔します。
わたしには回答できませんが、
質問だけしてもよいですか。

今回の転記は、すべて一方通行データのみですか。
それとも、DBから所定様式への読み込みもあるのですか。

(マナ) 2017/05/18(木) 21:24


マナさん、ご質問ありがとうございます。
所定様式への読み込みもあります。その中に一部、一方通行があります。
よろしくお願いします。
(トランプ) 2017/05/18(木) 21:30

"入出力"、"DB"、"転記"の3シートの詳細レイアウト(列:行)が示されないとわかりませんね。
(mm) 2017/05/19(金) 09:16

今夜、お送りします。
よろしくお願いします。
(トランプ) 2017/05/19(金) 09:43

コメント返信:

[ 一覧(最新更新順) ]


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