[[20250622184736]]　『別シートからデータを反映させたい』（おふね）　ページの最後に飛ぶ

『別シートからデータを反映させたい』（おふね）

sheet１には日々のデータ入力をし、毎日更新される。→個人名sheetにはひと月分のデータを入れたいので、sheet１の日付欄と同じ日の所に値を反映させたい。

sheet１（データ）
　　　1日（TODAY関数）
　　　
　　　　　　　　血圧上　下　　脈拍　体温　．．．．．．
　　　山田さん　140　　　88　　97 36.5
　　　鈴木さん　123　　　70　　65　　 36.4
　　　佐藤さん 98 63 80 36.8

sheet2（山田）
　　　　　1日　　　2日　　　3日
　血圧上　140
　　　下　88
　　脈拍　97
　　体温　36.5

sheet3（鈴木）
　　　　　1日　　　2日　　　3日
　血圧上　123
　　　下　70
　　脈拍　97
　　体温　36.4

翌日にはsheet1（データ）に2日のデータを入力するので、個別sheet（山田、鈴木）の2日の所にその値を反映させたい。1日分はOFFSETとROW関数を使用したが、日付に合わせて反映する方法を教えて下さい。

ご教授頂けると助かります。よろしくお願いします.

＜使用 Excel：Microsoft365、使用 OS：Windows11 ＞

行列を示したらどうですか。

＞OFFSETとROW関数を使用したが
式を提示したらどうでしょうか。
日付の分をその式に足すことができると思いますよ。

（?） 2025/06/22(日) 20:03:10

＞sheet１には日々のデータ入力をし、毎日更新される。
＞1日（TODAY関数）

これって、Sheet1の所定の入力欄に毎日"上書き"するということでしょうか。
そうなると、元のデータが失われるので数式で参照する場合、
都度、前日までのデータを値に変換する等の工夫が必要になると思いますが、
それはご承知の上ということでしょうか。

ひとまず、もう少し詳しい説明をされた方がよろしいかもしれません。
（コメ） 2025/06/22(日) 20:42:21

VBA は　いらんかいねぇ～　♪　^^;

m(__)m
（隠居Z） 2025/06/22(日) 21:12:20

ご返信ありがとうございます。
（コメ）さんの仰る通りSheet1の入力欄には毎日上書きします。なのでSheet１のTODAY関数を入れたセルと一致する個別sheetの日にちの所に相互参照で自動で反映出来たら・・・と思いまして。そうすると前日の1日の個別sheetが参照箇所が無くなりエラーになっちゃいますかね？

（隠居Z）さんのVBAで組めたら一番いいんですが・・・なんせマクロVBAは勉強し始めたばかりなもんで(;'∀')
（おふね） 2025/06/22(日) 21:37:00

こんばんわ　＾＾
何にでも最初はあるものかと。。。一度組めば自信につながりますですよ(*^^*)
小学校の算数とすこぉし英語さえ分かれば何とかなりますよ。←　私の事ですが。。。

またしかられそぉですが。。。何冊か関連書籍は読むようにいたしませう^^;
m(__)m

（隠居Z） 2025/06/22(日) 22:28:22

マクロ＆VBAの本を片手に勉強中ですが・・・基本は出来ても自分なりの応用はまだまだです(;´･ω･)精進してまいります♡
（おふね） 2025/06/22(日) 22:40:21

＞前日の1日の個別sheetが参照箇所が無くなりエラーになっちゃいますかね？
（コメ） 2025/06/22(日) 20:42:21さんの回答理解されていますか。

（?） 2025/06/23(月) 06:56:23

＞（コメ） 2025/06/22(日) 20:42:21さんの回答理解されていますか。
＞（?） 2025/06/23(月) 06:56:23
？？？
別に間違ったこと言ってないよね。
何が言いたいの、お爺ちゃん。はっきり言って。

それより
＞日付の分をその式に足すことができると思いますよ。
＞（?） 2025/06/22(日) 20:03:10
日付の分って何？　説明してちょうだい。

（しゅうかつお爺ちゃん） 2025/06/23(月) 10:00:57

私の早とちり。
スルーしてください。
（?） 2025/06/23(月) 11:39:58

↑
この人はいつもこんな感じ。
少し前に↓このようにかなりの辱めを受けたはずなのに、以降も同じ名前で盛んに活動してるのがいいですね。
[[20250514161940]]
「鋼のメンタル」はアッパレ。

（見習いたい） 2025/06/23(月) 12:28:42

例えば、

Option Explicit

Sub test()

    Dim wsSource As Worksheet
    Dim lastRow As Long, i As Long
    Dim nameList As Collection
    Dim ws As Worksheet
    Dim name As String
    Dim dateValue As Variant
    Dim foundRow As Long

    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set nameList = New Collection

    ' 名前リスト作成（重複なし）
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    On Error Resume Next
    For i = 3 To lastRow
        name = wsSource.Cells(i, 1).Value
        If name <> "" Then
            nameList.Add name, CStr(name)
        End If
    Next i
    On Error GoTo 0

    ' 名前ごとにシート作成（なければ）
    For i = 1 To nameList.Count
        name = nameList(i)
        If Not SheetExists(name) Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
            Set ws = Worksheets(name)
            ' ヘッダー作成
            ws.Range("A1").Value = "日付"
            ws.Range("B1").Value = "血圧（上）"
            ws.Range("C1").Value = "血圧（下）"
            ws.Range("D1").Value = "脈拍"
            ws.Range("E1").Value = "体温"
        End If
    Next i

    ' 各シートにデータ転記
    For i = 3 To lastRow
        name = wsSource.Cells(i, 1).Value
        If name <> "" Then
            Set ws = Worksheets(name)
            dateValue = wsSource.Range("A1").Value
            ' 既存データの最終行取得
            foundRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
            ws.Cells(foundRow, 1).Value = dateValue
            ws.Cells(foundRow, 2).Value = wsSource.Cells(i, 2).Value
            ws.Cells(foundRow, 3).Value = wsSource.Cells(i, 3).Value
            ws.Cells(foundRow, 4).Value = wsSource.Cells(i, 4).Value
            ws.Cells(foundRow, 5).Value = wsSource.Cells(i, 5).Value
        End If
    Next i

    MsgBox "データ転記が完了しました！"
End Sub

' シート存在確認関数
Function SheetExists(sheetName As String) As Boolean

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    SheetExists = Not ws Is Nothing
    On Error GoTo 0
End Function

（暇な人） 2025/06/23(月) 13:25:34

既にご案内ですが。。。配列使用案で。。。^^;
データー　シートが下記の様なフォーマットである場合。(￣▽￣；)

    |[A] |[B]     |[C]   |[D]    |[E] 
 [1]|    |        |      |       |    
 [2]|    |        |      |       |    
 [3]|    |=TODAY()|      |       |    
 [4]|    |        |      |       |    
 [5]|氏名|血圧上  |血圧下|脈拍/分|体温
 [6]|山田|     137|   141|     84|40.2
 [7]|鈴木|     185|    98|     51|43.7
 [8]|佐藤|     236|    99|     54|42.1
 [9]|    |        |      |       |

Option Explicit
Sub A000_OneInstanceMain()

    Dim w(), m(), d#
    A1000_NeedWsAdd w, m, d
    A2000_MoveWriteToPwS w, m, d
End Sub
Private Sub A2000_MoveWriteToPwS(w, m, d)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lC As Long
    Dim v()
    ReDim v(1 To 4, 1 To 1)
    For i = LBound(m) To UBound(m)
        For j = 1 To UBound(w, 1)
            If m(i) = w(j, 1) Then
                With Worksheets(m(i))
                    lC = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
                    With .Cells(1, lC)
                        .Value = d
                        .NumberFormatLocal = "d日"
                    End With
                    For k = 2 To UBound(w, 2)
                        v(k - 1, 1) = w(j, k)
                    Next
                    .Cells(2, lC).Resize(4) = v
                End With
            End If
        Next
    Next
    Erase v
End Sub
Private Sub A1000_NeedWsAdd(w, m, d)
    Dim Dc As Object
    Dim i As Long
    Dim j As Long
    Dim cN As Long
    Dim lR As Long
    Dim dKey()
    Dim eFlg As Boolean
    Set Dc = CreateObject("Scripting.Dictionary")
    With Worksheets("データ")
        d = .Range("b3").Value2
        w = .Cells(5, 1).CurrentRegion.Value
        lR = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 6 To lR
            Dc(.Cells(i, 1).Value) = Empty
        Next
    End With
    cN = Worksheets.Count
    dKey = Dc.keys
    For i = 0 To UBound(dKey)
        For j = 1 To cN
            If Worksheets(j).name = dKey(i) Then
                eFlg = True
                Exit For
            End If
        Next
        If Not eFlg Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = dKey(i)
            With Worksheets(dKey(i))
                .Cells(1).Resize(5) = Application.Transpose(Array("日付", "血圧上", "血圧下", _
                                                                  "脈拍/分", "体温"))
            End With
        End If
        eFlg = False
    Next
    m = dKey
    Erase dKey
    Dc.RemoveAll
End Sub
こんな感じでも。。。
情報の詳細も良く理解出来ておりませんので、何かの足しにでもなれば幸甚です
見当外れでしたらゴミ箱直行で。。。(*^^*)
情報が限界を超えたら、メンバーの入出次処理、その他諸々のエラー処理、便利機能は
一切御座いません、別途ご勘案下さいませ。でわでわ
頑張ってくださいね。。。<< _ _ >>

（隠居Z） 2025/06/23(月) 16:45:00

データベース的な視点からすると、表に日付の列を用意した方が扱い易いと思いますが、
上書きで入力したいご事情が有るのでしょう。

既にマクロ案のご紹介がありましたので、日付列を用意できた場合の数式案です。
実務上適してない場合もあるかもしれませんので、参考程度にして下さい。

 ＜Sheet1＞
    |[A]     |[B]      |[C]   |[D]|[E] |[F] 
 [1]|名前    |日付     |血圧上|下 |脈拍|体温
 [2]|山田さん|2025/6/23|   140| 88|  97|36.5
 [3]|鈴木さん|2025/6/23|   123| 70|  65|36.4
 [4]|山田さん|2025/6/24|   139| 87|  96|36.6
 [5]|佐藤さん|2025/6/24|   122| 71|  66|35.9
 [6]|鈴木さん|2025/6/25|   124| 77|  63|36.1
 [7]|鈴木さん|2025/6/26|   133| 98|  77|36.6

 ＜「山田さん」シート＞（シート名は名前列と同じにする）
    |[A]   |[B]      |[C]      
 [1]|      |2025/6/23|2025/6/24
 [2]|血圧上|      140|      139
 [3]|下    |       88|       87
 [4]|脈拍  |       97|       96
 [5]|体温  |     36.5|     36.6

 A2 =TRANSPOSE(Sheet1!C1:F1)
 B1 =TRANSPOSE(FILTER(FILTER(Sheet1!A:F,Sheet1!A:A=TEXTAFTER(CELL("filename",A1),"]")),{0,1,1,1,1,1}))

スピルするので他のセルが埋まっていないように、新規シートを用意した方が良いと思います。
（コメ） 2025/06/23(月) 20:09:46

コメント返信：

[ 一覧(最新更新順) ]

[[20250622184736]] 『別シートからデータを反映させたい』（おふね） ページの最後に飛ぶ

[[20250622184736]]　『別シートからデータを反映させたい』（おふね）　ページの最後に飛ぶ