別のシートに特定の文字だけ転送する計算式やVBA

質問

エクセルファイルのシート「No.１」のセルA１～A３０に氏名が入力されて、セルB１～E３０に氏名に振り分けられた文字が入力されています。
この文字には不定期にXとTの文字が入力されています。
そして、このシートに入力された氏名の順番や文字は毎月変更されます。

同じエクセルファイルのシート「No.２」のA１～A３０には順番が変更されない氏名が入力されて、B１～E３０は文字が何も入力されていない空白の状態です。

コマンドボタンを押すとシート「No.1」のA１～A３０に入力された氏名に該当するB1～E３０のXとTのみ抽出して、シート「No.2」のB１～E３０にXとTの文字のみを張り付けるVBAやセルに入力する計算式はどの様に行えば良いでしょうか？

回答No.3

emaxemax · ベストアンサー

1行変えるだけで対応できますよ。こんな感じ。

Sub TEST20210418()
Dim myV, myW
Dim i As Long, n As Long, j As Long
myW = Sheets("No.１").Range("A1:E30").Value
Sheets("No.２").Range("B1:E30").ClearContents
myV = Sheets("No.２").Range("A1:E30").Value
For i = 1 To 30
For n = 1 To 30
If myV(i, 1) = myW(n, 1) Then
For j = 2 To 5
If myW(n, j) = "X" Or myW(n, j) = "T" Then
myV(i, j) = IIf(myW(n, j) = "X", "－", "休")
End If
Next j
Exit For
End If
Next n
Next i
Sheets("No.２").Range("A1:E30").Value = myV
End Sub

お礼

ありがとうございました。
VBAを作成する際の参考になりました。

回答No.2

imogasi

この問題は小生は、梃子づった。下記方法よりも、
単純にSheet1のデータのある範囲の全セルを、舐める方法がよいのかも。
ーー
関数では複雑になりそうに思う。VBAしかないのかも。
ーー
質問の標題の、＞「転送する」は、適当でないように思う。
作業内容は、表のデータの抜出と組換えに当たる。
ーー
XやTのあるセルを見つける必要があるので、
VBAのFindを使う方法をやってみた。
・Findの利用は初心者にはむつかしいと思う。
・小生が、質問の内容を誤解していた場合でも、質問者にはＶＢＡの修正の技量はないのだろう。
　特に,シート「No.２」Ｓのデータ結果の、データ例さえ挙げずに質問するもんだから、
推測でやらざるを得なかった。
質問者のためには、あまり役立たないかも。
・小生は結構、梃子づった。満足してないが、趣味でやってみたことを、参考までに上げるしかない。
＝＝＝
基データは「Sheet1」にある、とする。
結果は「Sheet2」に出すとする。
ーー
前提
Sheet2には、名前データだけ既に作られていて、Ａ列にあり、好みの順に、行的に氏名は並んでいるとする。
データ例　Sheet1　Ａ２：Ｅ１１
山田 - X X -
大倉 - - - T
矢野 T X T
大野 - X - X
近藤 - T - -
佐藤 - - - X
今野 X - - -
木下 X T - T
熊野 T T - T
宮崎 - T X -
Sheet２には、A2:A11に
大倉
熊野
矢野
木下
山田
宮崎
近藤
佐藤
大野
今野
と、この順で並んでいるとする。質問者が指定したと模す。
ーー
標準モジュールに
Sub test02()
fndmoji = "X"
’fndmoji = "T"
strt:
Set Rng = Worksheets("Sheet1").Range("b2:E11").Find(what:=fndmoji, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not Rng Is Nothing Then
MsgBox Worksheets("Sheet1").Cells(Rng.Row, "A") & "=" & Rng.Address
GoSub dtset 'Sheetへセット
firstAddress = Rng.Address
Do

' 前回値が見つかったセルの次から検索
Set Rng = Worksheets("Sheet1").Range("b2:E11").FindNext(Rng) '２箇所目を探す
If Rng Is Nothing Then GoTo DoneFinding '見つからなかったら処理終了
'---最初の位置へ戻ったら終了
If Rng.Address = firstAddress Then GoTo DoneFinding
'---データをSheet2へセット
GoSub dtset
Loop While Rng.Address <> firstAddress
End If
'---調べつくした
DoneFinding:
GoTo owari
'----------------------Sheet2へデータセット-----------------
dtset:
'----画面標示
MsgBox Worksheets("Sheet1").Cells(Rng.Row, "A") & "=" & Rng.Address
'---見つかった時、名前を取得
Name = Worksheets("Sheet1").Cells(Rng.Row, "A") 'sheet1nのA列が名前
'--その名前の行を探す
For k = 2 To 11
If Worksheets("Sheet2").Cells(k, "A") = Name Then
'一番右のデータ列の次列を探す
c = Worksheets("Sheet2").Cells(k, 1000).End(xlToLeft).Column + 1
'--Sheet2のセルへデータをセット
Worksheets("Sheet2").Cells(k, c) = fndmoji & "-" & Rng.Address
Exit For
End If
Next k
Return
'-------------------------------------------
'---終了
owari:
Set Rng = Nothing
Set fndnm = Nothing
End Sub
まず上記で実行。
終了後にもう一度、初めの方の2行を下記に変えて実行。
'fndmoji = "X"
fndmoji = "T"
ーーー
結果
Sheet2のA2:D11に
これは、XとTの後に見つかったアドレスをくっつけた。
（本当はどうすべきか質問文では分らず。）
大倉 T-$E$3
熊野 T-$B$10 T-$C$10 T-$E$10
矢野 X-$C$4 T-$B$4 T-$D$4
木下 X-$B$9 T-$C$9 T-$E$9
山田 X-$C$2 X-$D$2
宮崎 X-$D$11 T-$C$11
近藤 T-$C$6
佐藤 X-$E$7
大野 X-$C$5 X-$E$5
今野 X-$B$8
ーー
２度実行を１度実行で済ます方法について、Findを使うがために、自信なくて。
最終行＝データ量は第１１行でやっているが、データの多寡で、１１を実態の最終行番号に置き換えるのは（VBA１行）たやすい。２箇所要修正。

お礼

ありがとうございました。
参考にVBAを組み立てていきたいと思います。

回答No.1

emaxemax

これでいかがでしょう？
Sub TEST20210417()
Dim myV, myW
Dim i As Long, n As Long, j As Long
myW = Sheets("No.１").Range("A1:E30").Value
Sheets("No.２").Range("B1:E30").ClearContents
myV = Sheets("No.２").Range("A1:E30").Value
For i = 1 To 30
For n = 1 To 30
If myV(i, 1) = myW(n, 1) Then
For j = 2 To 5
If myW(n, j) = "X" Or myW(n, j) = "T" Then
myV(i, j) = myW(n, j)
End If
Next j
Exit For
End If
Next n
Next i
Sheets("No.２").Range("A1:E30").Value = myV
End Sub

お礼

ありがとうございました。
VBAを作成する際の参考になりました。

補足

①XとTの文字を抽出して、Xの文字は｢－｣でTの文字の所は｢休｣にする場合はどう追加すれば良いですか？