別シートからの氏名の日付を入力

質問

シートAの表のような日付割り氏名欄があり個人がいつ出勤したか実績の月日をシートBの氏名ごとの出勤日を入力し回数を計上したいのですがどなたかExcel関数もしくはVBA関数の解る方よろしくお願いします。

回答No.9

watabe007 · ベストアンサー

>Worksheets("Sheet1").Range("範囲追加")に訂正したのですが。
>dateR = IIf(c.Row < 9, 2, 9)の数値を変え努力してますがうまくいきません。
すみません、範囲追加を想定していませんでした。
私の書いたコードでは修正が面倒なのでrealbeatinさんのコードを一部お借りして書き直してみました。
Sub Test2()
　　Dim c As Range, i As Long, myR As Variant, myC As Long
　　'日付の書かれた範囲を上からループ
　　For Each c In Worksheets("Sheet1").Range("C2:E2,C9:E9,C16:E16")
　　　　With Worksheets("Sheet2")
　　　　　　'Cは日付の書かれたセル
　　　　　　For i = 2 To 6
　　　　　　　　'日付の下に書かれた名前をシート2のB列より検索
　　　　　　　　myR = Application.Match(c.Offset(i).Value, .Columns(2), 0)
　　　　　　　　If IsError(myR) Then
　　　　　　　　　　'B列に名前が無ければ新たに登録
　　　　　　　　　　myR = .Cells(Rows.Count, "B").End(xlUp).Row + 1
　　　　　　　　　　.Cells(myR, "B").Value = c.Offset(i).Value
　　　　　　　　End If
　　　　　　　　'名前の行の右端の列を検索
　　　　　　　　myC = .Cells(myR, Columns.Count).End(xlToLeft).Column + 1
　　　　　　　　'名前の行の右端に日付を転記
　　　　　　　　.Cells(myR, myC).Value = c.Value
　　　　　　Next
　　　　End With
　　Next
End Sub

お礼

補足の回答も含めて有難うございます。新コード入力で可能になりました。
説明も記述していただき有難うございます。非常に助かり尚勉強になりました。今後も応用していきたいと思います。

回答No.8

msMike

Sheet1 において、
１．範囲 C2:E8 を選択して、Alt+MCL ⇒ [OK]
２．範囲 C9:E15 を選択して、Alt+MCL ⇒ [OK]

３．Sheet1 の範囲 C2:E2 を選択して、Ctrl+C
４．Sheet2 のセル C2 を選択して、Ctrl+V
５．Sheet1 の範囲 C9:E9 を選択して、Ctrl+C
６．Sheet2 のセル F2 を選択して、Ctrl+V

Sheet2 において、
７．次式を入力したセル C3 を右５列にオートフィル
￣￣ ="_"&YEAR(C2)&"_"&MONTH(C2)&"_"&DAY(C2)
８．セル B4 以降に、Sheet1 に登場する「氏名」全部を無重複で入力
９．次式を入力したセル C5 を右方および下方にオートフィル
￣￣ =IF(COUNTIF(INDIRECT(C$3),$B4),C$2,"")

10．Sheet2 の範囲 B4:B10 を選択して、Ctrl+C
11．Sheet3 のセル B4 を選択して、Ctrl+V

Sheet3 において、
12．yyyy/m/d に書式設定したセル C4 に次式を入力
￣￣ =IFERROR(SMALL(Sheet2!$C4:$H4,COLUMN(A1)),"")
13．セル C4 を右方および下方にオートフィル

お礼

有難うございます。勉強になりました。

回答No.7

bunjii

添付画像の範囲だけでしたらExcel 2007以降の組み込み関数で処理可能ですが数式が複雑で解読できないかも知れません。
尚、シートAとしている表はシート名がSheet1となっていますよね？
同様にシートBのシート名はSheet2なのでそれを基準に数式を作成しました。
Sheet2!C4=IFERROR(INDEX(Sheet1!$C$2:$E$2,SMALL(INDEX((Sheet1!$C$4:$E$8=$B4)*COLUMN($A4:$C4)+(Sheet1!$C$4:$E$8<>$B4)*10,0),COLUMN(A4))),IFERROR(INDEX(Sheet1!$C$9:$E$9,SMALL(INDEX((Sheet1!$C$11:$E$15=$B4)*COLUMN($A9:$C9)+(Sheet1!$C$11:$E$15<>$B4)*10,0),COLUMN(A4)-COUNTIF(Sheet1!$C$4:$E$8,$B4))),""))
この数式を右へH4セルまでコピーし、C4:H4を纏めて下へ10行目までコピーしてみました。
当方のExcelは2013です。
解説が必要であれば分からない部分を補足で提示してください。

お礼

有難うございます。勉強になりました。

回答No.6

Chiquilin

文章を読む限り VBAの知識はなさそうですから 人にマクロを組んで
もらっても全くメンテナンスできないでしょう。

例え 誰かのマクロを丸写しして解決したとしても短期間の内にまと
もに動かなくなるのが目に見えています。

Sheet2が必要だと最初から分かっているなら Sheet1を見直すことを
強くお勧めします。この表のままで得することがあるとは思えません。

回答No.5

imogasi

これは関数ではむつかしいと思う。
関数では２回目以後の該当分を探すのに適当な関数がない。
また熊谷、江藤、・・の社員氏名一覧を出すのもむつかしい。
Ｃ列以下、多数列に散らばっているのでフィルタでもむつかしい。
シートＢの氏名（Ｂ列）は、人間が手打ちする、でよいのか。
そうしないと複雑さが増す。
ーー
この部分をＶＢＡでやる一案は、参考に下記。
ーー
それでＶＢＡでやることになるが、相当ＶＢＡコードが複雑で、ＶＢＡを
相当長期にやっているものでないと難しい。
ということは回答者にコードを全的に書いてもらって丸写しするほかなくなる。
このコーナーは、仕事のためなどの、ＶＢＡなりのコードを作ってもらう
場所ではないはず。
またＶＢＳのDictionaryなどを持ち出した回答も出ているが、VBSの勉強も
望むらくは必要。
ーー
社員氏名一覧をＶＢＡでやると
ＶＢＳのＤｉｃｔｉｏｎａｒｙなど使わないでやると
データ例は
Ｂ２：Ｄ５とB9:D１２に

山田 大下 大野
今井 木村 山田
木下 大野 大野
山田 今井 大下

山田 大村 大野
今井 木村 山田
木下 大木 大野
山村 今井 大下

として
ーー
標準モジュールに
Sub test02()
r = 1
For Each cl In Range("B2:D5", "B9:D12")
If cl <> "" Then
If Application.WorksheetFunction.CountIf(Range("h1:H100"), cl) = 0 Then
Cells(r, "H") = cl
r = r + 1
End If
End If
Next
End Sub
ーー
実行結果
Ｈ列に
山田
大下
大野
今井
木村
木下
大村
大木
山村

ーー
質問ではＣ４：Ｅ８のような塊が複数個あるので
Range("B2:D5")の部分をRange("B2:D5", "B9:D12")にした。
このように本番では、複数個を、カンマで区切って付け加える。
すでに回答もあり、長くなるのでと、りあえず望む最終結果＝後半は略。

お礼

有難うございます。勉強になりました。

回答No.4

watabe007

シートA(Sheet1)の表のからシートB(Sheet2)に出力しています。
Sub Test()
Dim c As Range, dateR As Long, myR As Variant, myC As Long
Worksheets("Sheet2").Range("B3").Value = "氏名"
For Each c In Worksheets("Sheet1").Range("C4:C8,D4:D8,E4:E8,C11:C15,D11:D15,E11:E15")
dateR = IIf(c.Row < 9, 2, 9)
myR = Application.Match(c.Value, Worksheets("Sheet2").Columns(2), 0)
With Worksheets("Sheet2")
If IsError(myR) Then
myR = .Cells(Rows.Count, "B").End(xlUp).Row + 1
.Cells(myR, "B").Value = c.Value
End If
myC = .Cells(myR, Columns.Count).End(xlToLeft).Column + 1
.Cells(myR, myC).Value = Worksheets("Sheet1").Cells(dateR, c.Column).Value
End With
Next
End Sub

お礼

有難うございます。

補足

有難うございます。枠内への日付入力出来ました。
因みにセル枠を増やし下記のように追加してコードもFor Each c In Worksheets("Sheet1").Range("範囲追加")に訂正したのですが。
dateR = IIf(c.Row < 9, 2, 9)の数値を変え努力してますがうまくいきません。上記式の説明もお願いしたいのですが。また変数Cの値は何でしょうか。データベースの値が多くそこをクリアできず困ってます宜しくお願いします。
【追加枠】・・・上記表と同セル枠です
日付 2017/9/16 　2017/9/17 2017/9/18
氏名/班 A 　　　B 　　　　C
　1 　　大原 　　近藤 　　　下林
　2 　　江藤 　　江藤 　　　熊谷
　3 　　下林 　　熊谷 　　　江下
　4 　　江下 　　江下 　　　大原
　5 　　熊谷 　　下林 　　　田川

回答No.3

real beatin（@realbeatin）

No.2です。
提示したマクロに漏れがありました。
たぶん、そちらではエラーで停まってしまう筈です。
以下のものに差し替えをお願いします。

' ' // 元の表 の内にあるセルを選択してから実行
Sub Re9377246Wa()
Dim oDict As Object, rSrc As Range, c As Range
Dim vK, vI, sTmp As String, cnP As Long, i As Long
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Set rSrc = Selection.CurrentRegion _
　　　　.Offset(, 1).SpecialCells(xlCellTypeConstants, xlNumbers)
　　For Each c In rSrc
　　　　For i = 3 To 7
　　　　　　sTmp = c(i, 1)
　　　　　　If sTmp <> "" Then oDict(sTmp) = oDict(sTmp) & vbTab & c.Text
　　　　Next i
　　Next
　　cnP = oDict.Count
　　vK = oDict.Keys:　　vI = oDict.Items
　　With Worksheets.Add(After:=ActiveSheet).Cells(3, 2)
　　　　For i = 0 To cnP - 1
　　　　　　.Cells(i + 1, 1) = vK(i) & vI(i)
　　　　Next i
　　　　.Resize(cnP).TextToColumns _
　　　　　　Destination:=.Cells, DataType:=xlDelimited, Tab:=True, _
　　　　　　Semicolon:=False, Comma:=False, Space:=False, Other:=False
　　　　.Cells(0).Resize(, 2) = Array("氏名", "日付")
　　　　With .CurrentRegion
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　.Columns.AutoFit
　　　　　　.Cells(2).Resize(, .Columns.Count - 1).Merge
　　　　　　.HorizontalAlignment = xlCenter
　　　　End With
　　End With
End Sub
' ' //

お礼

有難うございます。解読が難しく理解するよぅ勉強します。

回答No.2

real beatin（@realbeatin）

マクロを書きました。
どこでもいいので、元の表の内側のセルを選択してある状態
から実行すると、新しいシートに作表します。
条件の説明がなく、添付画像だけが頼りで書いていますから、
元の表やその周辺のレイアウトが画像と違っている場合は、
手当てを加えて使うことになります。
一旦は、添付画像の元となった表で験してみてください。
Excelのバージョンは、2000-2003あたりのようですが、
Excelに関してはバージョン互換を図った内容にしました。
OSに関してはWindows限定（Macでは動かないと思います）です。
この手の回答は、使用環境に合わせて内容を工夫することにも
神経を使います。（万能なものは意外に無いものなので。）
以後、OSやOfficeのバージョン等必要な情報として、
ご使用の環境を開示して質問するようにして下さいませ。
その方が回答し易くなる分、回答を受ける機会も増え、
問題解決の可能性も高まることになろうかと思われますので。

' ' // 元の表 の内にあるセルを選択してから実行
Sub Re9377246Wa()
Dim oDict As Object, rSrc As Range, c As Range
Dim vP, sTmp As String, cnP As Long, i As Long
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Set rSrc = Selection.CurrentRegion _
　　　　.Offset(, 1).SpecialCells(xlCellTypeConstants, xlNumbers)
　　For Each c In rSrc
　　　　For i = 3 To 7
　　　　　　sTmp = c(i, 1)
　　　　　　If sTmp <> "" Then oDict(sTmp) = oDict(sTmp) & vbTab & c.Text
　　　　Next i
　　Next
　　cnP = oDict.Count
　　With Worksheets.Add(After:=ActiveSheet).Cells(3, 2)
　　　　For i = 0 To cnP - 1
　　　　　　.Cells(i + 1, 1) = oDict.Keys(i) & oDict.Items(i)
　　　　Next i
　　　　.Resize(cnP).TextToColumns _
　　　　　　Destination:=.Cells, DataType:=xlDelimited, Tab:=True, _
　　　　　　Semicolon:=False, Comma:=False, Space:=False, Other:=False
　　　　.Cells(0).Resize(, 2) = Array("氏名", "日付")
　　　　With .CurrentRegion
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　.Columns.AutoFit
　　　　　　.Cells(2).Resize(, .Columns.Count - 1).Merge
　　　　　　.HorizontalAlignment = xlCenter
　　　　End With
　　End With
End Sub
' ' //

お礼

有難うございます。勉強になりました。

回答No.1

akauntook

せっかくの画像が小さすぎるので、文字が潰れて何もわかりません。

お礼

申し訳ありません指導有難うございます。