一行の中から複数の値を抜き出す。

質問

エクセルを使用し、画像の上側のような表を作っています。説明の為、短くしてありますが実際のファイルは横にずらーっと日付が並んでおり、一年で一つのファイルです。月ごとにタブを設定しています。
部屋番号も下に10ほど並んでおります。
画像を一枚に収めるために、表を二つ入れてありますが、実際にはこの二つの表は別々のファイルにしたいです。(上側の表のファイル名を名簿.xlsxlとします)

名簿.xlsxを別のエクセルファイル(宿泊一覧.xlsx)から読み込んで、
名簿.xlsxから宿泊者名を自動で抜き出して、滞在日数や泊数を計算させて表を作成させることは可能でしょうか？
画像を一枚に収めるために、表を二つ入れてありますが、実際にはこの二つの表は別々のファイルにしたいです。
名簿.xslxをどんどん更新すると、宿泊一覧にも名前が更新されるようにしたいのですが、関数だけではできないものなんでしょうか？
VBAはよくわからないので、できれば関数でやるやり方を教えて頂ければありがたいです。

回答No.9

mt2008

ANo.8です。
ごめんなさい、ミスがありました。
「End Sub」の2つ上の行を以下の様に修正してください。

誤：Worksheets(1).Range("A2:C" & nCount) = vData2
↓
正：Worksheets(1).Range("A2:C" & nCount + 1) = vData2

回答No.8

mt2008

いっぱい回答が付いているのでいまさら感が有りますが、VBAでやる場合です。

前提は、
・宿泊者名はかならず「様」が付く
・月跨ぎは前の月の最終日は「→」（月末にチェックインの場合は宿泊者名）で終わり、次の月の1日は「→」または「退」で始まる
・年跨ぎは無い。
・名簿のシート名は「4月」～「3月」で、12か月分ちゃんとある

宿泊一覧.xlsm　に以下のコードを入れて実行してください。
宿泊一覧ブックの1枚目のシートのA2以下に名前とイン、アウトを貼り付けます。
日数や泊数はExcelの演算式で出してください。

Sub Sample()
　　Dim vData()　　
　　nCount = 0 '宿泊総回数
　　nLastRow = 5 '使用している最終行（実際の名簿に合わせて変える）

　　Application.ScreenUpdating = False
　　Workbooks.Open Filename:="C:\名簿.xlsx" '実際の保存場所に合わせて修正
　　With ActiveWorkbook
　　　　For i = 3 To nLastRow '列ごとに処理（データは3行目から有るものとしています）
　　　　　　For j = 0 To 11 '「4月」～「3月」までの月別シートごとに処理
　　　　　　　　sShtName = Month(DateAdd("M", j, "4/1")) & "月" '対象シート名
　　　　　　　　For k = 2 To 32 '日にち毎にチェック（手抜きで2月も小の月も31日分チェック）
　　　　　　　　　　sData = .Sheets(sShtName).Cells(i, k).Value
　　　　　　　　　　Select Case True
　　　　　　　　　　Case sData Like "*様" 'セルの値に「様」を含んでいればチェックイン
　　　　　　　　　　　　ReDim Preserve vData(2, nCount)
　　　　　　　　　　　　vData(0, nCount) = sData
　　　　　　　　　　　　vData(1, nCount) = .Sheets(sShtName).Cells(1, k).Value

　　　　　　　　　　Case sData = "退" 'セルの値が「退」ならチェックアウト
　　　　　　　　　　　　vData(2, nCount) = .Sheets(sShtName).Cells(1, k).Value
　　　　　　　　　　　　nCount = nCount + 1
　　　　　　　　　　End Select
　　　　　　　　Next k
　　　　　　Next j
　　　　Next i
　　　　.Close
　　End With
　　'行列を入れ替えて宿泊一覧に貼り付け
　　vData2 = Application.WorksheetFunction.Transpose(vData)
　　Worksheets(1).Range("A2:C" & nCount) = vData2
　　Application.ScreenUpdating = True
End Sub

回答No.7

tom04

親の仇のように顔を出してごめんなさい。

一番大切な下準備を書き忘れていました。
「名簿」Bookの最後の「作業用」Sheetの1行目にシリアル値を入れるコトを記載し忘れていました。

「名簿」Bookの13番目「作業用」SheetのA1セルに
4/1　と入力　→　ホームタブの左上のΣマークの下の「フィル」のアイコン（箱の中に↓の印があるアイコン）をクリック
→　連続データの作成　→　「行」・「日付」が選択されている状態で
「増加単位」は「日」・「増加値」は「1」となっているコトを確認し
「停止値」に　2014/3/31　と入力しOK

これで1行目に来年の3月31日までのシリアル値が表示されます。

これをやっていないと全く意味のないコードになってしまいます。

ほんとぉ～！っに何度もごめんなさいね。m(_ _)m

回答No.6

tom04

何度もごめんなさい。
前回のコードを↓に変更してください。

前回は余計なコトをしていたようで、「宿泊一覧」Bookを開くコードを入れたつもりですが、
実際は保存場所等（フルパス）を記載しなければならないはずですので、
「宿泊一覧」Bookは開いた状態で↓のマクロを実行してください。
（おそらく前回のコードではエラーになってしまうと思います）

Sub 名簿更新2() 'この行から
Dim i As Long, j As Long, k As Long, endRow As Long, endCol As Long
Dim c As Range, wS1 As Worksheet, wS2 As Worksheet
Workbooks("名簿").Activate
Set wS1 = Worksheets("作業用")
Set wS2 = Workbooks("宿泊一覧").Worksheets("Sheet1")
endRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(endRow, "C")).ClearContents
End If
endRow = wS1.UsedRange.Rows.Count
If endRow > 1 Then
wS1.Rows(2 & ":" & endRow).ClearContents
End If
For k = 1 To 12
With Worksheets(k)
Set c = wS1.Rows(1).Find(what:=.Cells(1, "B"), LookIn:=xlValues, lookat:=xlWhole)
j = c.Column
endRow = .UsedRange.Rows.Count
endCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Range(.Cells(2, "B"), .Cells(endRow, endCol)).Copy wS1.Cells(2, j)
End With
Next k
For i = 3 To wS1.UsedRange.Rows.Count
For j = 1 To wS1.Cells(1, Columns.Count).End(xlToLeft).Column
If wS1.Cells(i, j) <> "" And wS1.Cells(i, j) <> "→" And wS1.Cells(i, j) <> "退" Then
With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = wS1.Cells(i, j)
.Offset(, 1) = wS1.Cells(1, j)
k = j
Do Until wS1.Cells(i, k) = "退"
k = k + 1
Loop
.Offset(, 2) = wS1.Cells(1, k)
End With
j = k
End If
Next j
Next i
wS2.Range("A1").CurrentRegion.Sort key1:=wS2.Range("B1"), order1:=xlAscending, Header:=xlYes
wS2.Columns.AutoFit
End Sub 'この行まで

※　尚、保存時にはファイルの種類を「Excelマクロ有効ブック」で保存してください。

何度も失礼しました。m(_ _)m

回答No.5

tom04

No.1～3です。

補足を読みました。
結局　名簿Bookには各月1Sheetで12Sheetあり、当然のコトながら月跨ぎでの宿泊もある！
というコトですね！
いずれにしても1年分を1Sheetにまとめた方が処理が簡単だと思います。
関数で！というとかなり厄介になりますので、VBAでやってみました。
ただし、下準備として
↓の画像で左側が「名簿」Bookの各Sheetのレイアウトになります。
Sheet見出し上には4月～翌年の3月までの12Sheetが存在するとしています。
「4月」のSheet見出しをクリック　→　Shiftキーを押しながら最後の3月のSheet見出しをクリック！
これで12Sheetが作業グループ化されましたので

A1セルを選択　→　右クリック　→　セルの書式設定　→　表示形式　→　ユーザー定義から
0年
と入力　→　OK
A2セルを選択　→　右クリック　→　セルの書式設定　→　表示形式　→　ユーザー定義から
0月度
と入力　→　OK
B1セル　→　セルの表示形式はユーザー定義から
d
としておき、
=IF(MONTH(DATE($A1,$A2,COLUMN(A1)))=$A2,DATE($A1,$A2,COLUMN(A1)),"")
という数式を入れます。
B2セルの数式は
=IF(B1="","",TEXT(B1,"aaa"))
として、B1・B2セルを範囲指定　→　B2セルのフィルハンドルで31日分のAF列までコピー！
→　Sheet見出し上で右クリック　→　作業グループ化を解除
各SheetのA1・A2セルに「年」と「月」の数値のみを入力していきます。
これで第一段階の準備は完了です。

この「名簿」Bookの13Sheet目を追加して　Sheet名を「作業用」としておきます。
VBAでこの「作業用」Sheetに1年分のデータを表示させ、
そのデータを利用し、↓の画面右側の「宿泊一覧」BookのSheet1に表示させます。

「宿泊一覧」のSheet1のD2セルに
=IF(A2="","",C2-B2+1)
E2セルに
=IF(A2="","",C2-B2)
という数式を入れ両列ともオートフィルでしっかり下へコピーしておいてください。
これで下準備は完了です。

最後に「名簿」Bookを開き　→　Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュールに
↓のコードをコピー＆ペーストしマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub 名簿更新() 'この行から
Dim i As Long, j As Long, k As Long, endRow As Long, endCol As Long
Dim c As Range, wS1 As Worksheet, wS2 As Worksheet

Application.DisplayAlerts = False
Workbooks.Open ("宿泊一覧")
Application.DisplayAlerts = True
Workbooks("名簿").Activate
Set wS1 = Worksheets("作業用")
Set wS2 = Workbooks("宿泊一覧").Worksheets("Sheet1")
endRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(endRow, "C")).ClearContents
End If
endRow = wS1.UsedRange.Rows.Count
If endRow > 1 Then
wS1.Rows(2 & ":" & endRow).ClearContents
End If
For k = 1 To 12
With Worksheets(k)
Set c = wS1.Rows(1).Find(what:=.Cells(1, "B"), LookIn:=xlValues, lookat:=xlWhole)
j = c.Column
endRow = .UsedRange.Rows.Count
endCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Range(.Cells(2, "B"), .Cells(endRow, endCol)).Copy wS1.Cells(2, j)
End With
Next k
For i = 3 To wS1.UsedRange.Rows.Count
For j = 1 To wS1.Cells(1, Columns.Count).End(xlToLeft).Column
If wS1.Cells(i, j) <> "" And wS1.Cells(i, j) <> "→" And wS1.Cells(i, j) <> "退" Then
With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = wS1.Cells(i, j)
.Offset(, 1) = wS1.Cells(1, j)
k = j
Do Until wS1.Cells(i, k) = "退"
k = k + 1
Loop
.Offset(, 2) = wS1.Cells(1, k)
End With
j = k
End If
Next j
Next i
wS2.Range("A1").CurrentRegion.Sort key1:=wS2.Range("B1"), order1:=xlAscending, Header:=xlYes
wS2.Columns.AutoFit
End Sub 'この行まで

※　今回も顧客名に重複はない！という前提です。
※　画像で、「田中」さんは月跨ぎにしてみました。
※　名簿シートの入力方法は画像のように最初に「お客様名」途中は「→」最後は「退」とします。

関数でないのでデータ変更があるたびにマクロを実行する必要があります。

この程度が今の段階では精一杯です。m(_ _)m

回答No.4

mt2008

関数でやるにしてもVBAでやるにしても、月跨ぎ年跨ぎの場合がどうなっていてどの様にしたいのか解らないとなぁ……。

回答No.3

tom04

続けてお邪魔します。

名簿ファイルの作業用Sheet2の数式を前回の数式に変更すると
表示したいC列の数式も変わってしまいます。

C2セルの数式を
=IFERROR(INDEX([名簿.xlsx]Sheet1!$A$1:$OJ$1,,SUMPRODUCT(([名簿.xlsx]Sheet2!$A$1:$OJ$300=A2)*COLUMN($A$1:$OJ$1))),"")
に変更してください。
他の列の数式はそのままで大丈夫だと思います。

何度も失礼しました。m(_ _)m

補足

沢山書いていただいてありがとうございます！
表の矢印は入れておきたいのですが、その場合にはまた関数が変わってくるのでしょうか？
4月から3月までタブがあり、例えば5月のタブを押すと5月以降の表が表示されます。前月からの方は1日の欄に田中様なら(田中様)等とと表示しています。
出来れば月またぎの方の日数も計算できるようにしたいです。

回答No.2

tom04

No.1です！
たびたびごめんなさい。

前回の数式では「→」に対処できていませんので、
元データに「→」は入力しないで作業用Sheet2のB3セルの数式を↓に変更してください。

=IF(Sheet1!B3="","",IF(Sheet1!B3="退",INDEX(Sheet1!$A3:A3,,MAX(IF(Sheet1!$A3:A3<>"",COLUMN($A$3:A3)))),COLUMN()*1000+ROW()))

前回同様、配列数式です。

※　どうしても「→」を入力したい場合は別途数式を考える必要があります。
検証せずに投稿してごめんなさいね。m(_ _)m

お礼

三件の回答ありがとうございます！
補足は三件目にまとめて書かせていただきました。

回答No.1

tom04

こんばんは！
関数での方法をご希望だというコトですので・・・
一例です。

名簿.xlsx　のSheet2を作業用のSheetとして使用します。
尚、元データはSheet1にあり、名前の重複はない！という前提です。
日付はシリアル値とします。
1年分のデータというコトですので、400列（OJ列）まで、行は300行までの数式としています。

名簿.xlsx　のSheet2のB3セルに
=IF(Sheet1!B3="","",IF(Sheet1!B3="退",INDEX(Sheet1!$A3:A3,,MAX(IF(Sheet1!$A3:A3<>"",IF(Sheet1!$A3:A3<>"→",COLUMN($A$3:A3)))))&"_"&Sheet1!B3,COLUMN()*1000+ROW()))
これは配列数式になってしまいますので、Shift＋Ctrl＋Enterで確定！
この画面からコピー＆ペーストする場合は、上記数式をドラッグ＆コピー　→　Sheet2のB3セルを選択
→　数式バー内に貼り付け　→　そのまま（編集可能なまま）Shift＋Ctrlキーを押しながらEnterキーで確定！
数式の前後に｛　｝マークが入り配列数式になります。
これをOJ列まで、300行までコピーしておきます。

そして表示したいファイルのA2セルに
=IFERROR(INDEX([名簿.xlsx]Sheet1!$A$1:OJJ$300,MOD(SMALL([名簿.xlsx]Sheet2!$A$1:$OJ$300,ROW(A1)),1000),INT(SMALL([名簿.xlsx]Sheet2!$A$1:$OJ$300,ROW(A1))/1000)),"")

B2セルに
=IFERROR(INDEX([名簿.xlsx]Sheet1!$A$1:$OJ$1,,SUMPRODUCT(([名簿.xlsx]Sheet1!$A$1:$OJ$300=A2)*COLUMN($A$1:$OJ$1))),"")

C2セルに
=IF(A2="","",INDEX([名簿.xlsx]Sheet1!$A$1:$OJ$1,,SUMPRODUCT(([名簿.xlsx]Sheet2!$A$1:$OJ$300=A2&"_"&"退")*COLUMN($A$1:$OJ$1))))

D2セルに
=IF(A2="","",C2-B2+1)

E2セルに
=IF(A2="","",C2-B2)

A2～E2セルを範囲指定　→　E2セルのフィルハンドルで下へコピー！

これで何とかご希望に近い形にならないでしょうか？
※　セルの表示形式は各列日付なり、○日　としてみてください。m(_ _)m

お礼

回答ありがとうございます！
補足は三件目にまとめて書かせていただきました。
私には少し難しいようですが、試してみます。
ありがとうございます！