| |
marai さんへ
ずいぶん音沙汰無くてすみません。
いまさら書いてもしょうがないかも知れませんが。
前回までのシートイメージで
・セルＢ４〜人数分の氏名をリスト化しておく。
・下記マクロが動くボタン等をつける
・全員に送信
・マクロで各個人名のファイルを保存 今回も"D:\エクセル\緊急連絡先Ｗｅｂ\"で設定
Sub 氏名で保存()
Dim TargetStr As String '氏名の確認用
Dim TargetStrL As String '氏名検索用
Dim LastRow As Integer 'シート最終行
Dim TargetArea As Range '氏名リスト
Dim FoundCell As Range '氏名確認用
Dim FoundCellL As Range '氏名検索用
Dim R As Integer
Dim N As Integer
Dim 名前1 As Integer 'メッセージ戻り値1
Dim 名前2 As Integer 'メッセージ戻り値2
TargetStr = Range("B2")
LastRow = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
Set TargetArea = Range("B4:B" & LastRow)
Set FoundCell = TargetArea.Find(what:=TargetStr, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False) '氏名リストから氏名を検索しての結果
If FoundCell Is Nothing Then '氏名リストに無かった場合
TargetStrL = Left(Range("B2"), 1) & "*" '氏名の最初の一文字
Set FoundCellL = TargetArea.Find(what:=TargetStrL, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False) '氏名リストから氏名の最初の一文字検索しての結果
R = FoundCellL.Row '見つかったセルのRow
On Error Resume Next
名前1 = MsgBox(FoundCellL.Value & "さんですか？", 3, "名前検索")
Select Case 名前1
Case 2 'キャンセルの時
Exit Sub
Case 6
Range("B2") = FoundCellL.Value 'はい。なら氏名書き込み
Case 7 'いいえ。の時
N = 1
Do 'はい。まで次々検索
Set FoundCellL = TargetArea.FindNext(After:=FoundCellL)
If FoundCellL.Row = R Then Exit Do
N = N + 1
名前2 = MsgBox(FoundCellL.Value & "さんですか？", 3, "名前検索")
Select Case 名前2
Case 2
Exit Sub
Case 6
Range("B2") = FoundCellL.Value
Exit Do
Case 7
End Select
Loop
End Select
End If
Set FoundCell = Nothing
Set TargetArea = Nothing
Range("A4:B" & LastRow).Delete
ActiveWorkbook.SaveAs Filename:="D:\エクセル\緊急連絡先Ｗｅｂ\" & Range("B2") '保存
MsgBox "完了"
End Sub
で、
編集用ブックに
Sub 編集()
Dim TargetStr As String '氏名の確認用
Dim LastRow As Integer 'シート最終行
Dim folName As String
Dim henSyuuB As String
Dim simeiArea As Range
Dim koko As Range
henSyuuB = ThisWorkbook.Name '編集用ブックの名前
folName = "D:\エクセル\緊急連絡先Ｗｅｂ"
LastRow = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
Set simeiArea = Range(Cells(2, 2), Cells(LastRow, 2))
For i = 2 To LastRow
TargetStr = Range("B" & i)
If Range("B" & i).Interior.ColorIndex <> 6 Then 'もし黄色じゃなかったら
Set fs = Application.FileSearch
With fs
.LookIn = folName
.Filename = TargetStr & ".xls"
If .Execute() > 0 Then
Workbooks.Open Filename:=folName & "\" & TargetStr & ".xls"
Windows(TargetStr & ".xls").Activate
Range("C2:M2").Copy
Windows(henSyuuB).Activate
Set koko = simeiArea.Find(what:=TargetStr, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
koko.Offset(0, 1).Select
ActiveSheet.Paste
koko.Select
With Selection.Interior '氏名を黄色で塗る
.ColorIndex = 6
End With
Windows(TargetStr & ".xls").Close
Else
End If
End With
End If
Next
End Sub
上記マクロで編集
と考えました。私のやりたいことが伝わったでしょうか？
エラー処理等甘い点があるかもしれませんが、処理が終わった人のセルは黄色に
塗潰されるようにしました。
解決されているのはわかっていますが、自分の為にアップしました。
（前回のレスが、中途半端な気持ちでの書き込みと思われたくなかったため）
コードに不備があれば教えて下さい。
ＰＳ.インフルエンザ以外にも風邪がはやっています。私はのどの痛みと高熱で３日寝込みました。
皆さんは、健康に気を付けてください。
かみちゃんさんの BSMTP.DLL はとても興味がわきました。今度試してみます。
質問できる位理解したとき、書き込むかも知れませんがその時はよろしくお願いします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 07/12/8(土) 13:56 -
