Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


28990 / 76732 ←次へ | 前へ→

【53031】Re:年末年始の行動予定表(緊急連絡用)
発言  あゆたろう  - 07/12/12(水) 16:54 -

引用なし
パスワード
   marai さんへ

ずいぶん音沙汰無くてすみません。
いまさら書いてもしょうがないかも知れませんが。

前回までのシートイメージで
・セルB4〜人数分の氏名をリスト化しておく。
・下記マクロが動くボタン等をつける
・全員に送信
・マクロで各個人名のファイルを保存 今回も"D:\エクセル\緊急連絡先Web\"で設定

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:\エクセル\緊急連絡先Web\" & 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:\エクセル\緊急連絡先Web"
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

上記マクロで編集

と考えました。私のやりたいことが伝わったでしょうか?

エラー処理等甘い点があるかもしれませんが、処理が終わった人のセルは黄色に
塗潰されるようにしました。
解決されているのはわかっていますが、自分の為にアップしました。
(前回のレスが、中途半端な気持ちでの書き込みと思われたくなかったため)
コードに不備があれば教えて下さい。

PS.インフルエンザ以外にも風邪がはやっています。私はのどの痛みと高熱で3日寝込みました。
皆さんは、健康に気を付けてください。
 かみちゃんさんの BSMTP.DLL はとても興味がわきました。今度試してみます。
質問できる位理解したとき、書き込むかも知れませんがその時はよろしくお願いします。
1 hits

【52773】年末年始の行動予定表(緊急連絡用) marai 07/12/2(日) 23:56 質問
【52775】Re:年末年始の行動予定表(緊急連絡用) neptune 07/12/3(月) 9:50 発言
【52784】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/3(月) 21:39 発言
【52809】Re:年末年始の行動予定表(緊急連絡用) あゆたろう 07/12/4(火) 17:43 発言
【52816】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/4(火) 22:57 発言
【52819】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/5(水) 2:03 発言
【52821】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/5(水) 7:35 発言
【52836】Re:年末年始の行動予定表(緊急連絡用) あゆたろう 07/12/5(水) 15:20 発言
【52862】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/7(金) 7:02 発言
【52869】Re:年末年始の行動予定表(緊急連絡用) あゆたろう 07/12/7(金) 11:57 発言
【52890】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/7(金) 22:56 発言
【52892】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/7(金) 23:08 発言
【52893】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/8(土) 4:26 発言
【52898】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/8(土) 13:56 発言
【52903】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/8(土) 21:21 お礼
【52911】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/9(日) 11:48 発言
【52912】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/9(日) 15:19 発言
【52913】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/9(日) 15:36 発言
【52916】Re:年末年始の行動予定表(緊急連絡用) りん 07/12/9(日) 16:12 発言
【52921】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/9(日) 17:19 発言
【52924】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/9(日) 17:37 発言
【52925】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/9(日) 18:02 発言
【52929】Re:年末年始の行動予定表(緊急連絡用) かみちゃん 07/12/9(日) 19:05 発言
【52933】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/9(日) 20:17 お礼
【52978】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/10(月) 19:11 お礼
【53031】Re:年末年始の行動予定表(緊急連絡用) あゆたろう 07/12/12(水) 16:54 発言
【53050】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/12(水) 21:02 お礼
【52785】Re:年末年始の行動予定表(緊急連絡用) お願い 07/12/3(月) 22:28 発言
【52787】Re:年末年始の行動予定表(緊急連絡用) marai 07/12/4(火) 6:10 発言
【52788】Re:年末年始の行動予定表(緊急連絡用) お願い 07/12/4(火) 8:33 発言

28990 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free