[[20170113164036]]　『一覧からシートを順番に作成し、一覧から値を取得』（marco3）　ページの最後に飛ぶ

『一覧からシートを順番に作成し、一覧から値を取得し張り付ける（VBA）』（marco3）

Excel初心者です。
『賃金一覧』シートに社員一覧があり、社員一覧全員分のシートを『原本』シートをコピーして追加作成したいと思ってます。

・追加シートについて、シート名は一覧の「シート名」とする。
・一覧全員分の追加シートを作成する。
（『原本』シートをコピーしてシート後ろに順番に追加する）
・一覧から「氏名」「ID」「基本給」等の情報を追加したシートのセルに順番にいれたい。

どうしたらいいか分からないので教えてほしいです。

ちなみに
★【賃金一覧】シート内の社員一覧は
A列：ID
B列：氏名
C列：シート名
D列：基本給
という作りになっており、社員増減します。

★追加シートへの各値のセルは下記のとおりです。
・ID：M2
・氏名：T2
・基本給：AI1

よろしくお願いします。

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

 一例です。

 Sub Sample()
    Dim c As Range
    Dim shn As String

    Application.ScreenUpdating = False

    With Sheets("賃金一覧")
        For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            shn = c.Offset(, 2).Value
            Application.DisplayAlerts = False
            On Error Resume Next
            Sheets(shn).Delete
            On Error GoTo 0
            Application.DisplayAlerts = True
            Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
            DoEvents    'おまじない
            With Worksheets(Worksheets.Count)
                .Range("M2").Value = c.Value
                .Range("T2").Value = c.Offset(, 1).Value
                .Range("AI1").Value = c.Offset(, 3).Value
                .Name = shn
            End With
        Next
    End With

 End Sub

（β） 2017/01/13(金) 19:50

βさん、ありがとうございました。
早速試したところ、完璧な動作でした。

一点追加の質問なのですが、このマクロは一覧表全員分を作成しますが、指定した社員IDの方のシート1枚のみ追加作成する時はどうするのがいいでしょうか？
メッセージボックスを表示させて社員IDを入力させて…
というやり方しか思いつかないのですが、その場合のコードを教えてほしいです。
（marco3） 2017/01/14(土) 08:56

 多くのメンバから１つ選ぶならコンボボックスやリストボックスを用意して、そこから選択させるとか
 あるいは、当該行を選択して実行ということも考えられますが、社員IDを入力して処理するとして、一例です。

 ★状況依存になっていたコードが１つあったので修正しました。(1/15 10:20)

 　ところで、どこかのシートのどこかのセルに入力規則で社員IDのリストを設定しておき
 　そこを選んだ時に自動実行　というやりかたもありますね。

 Sub Sample2()
    Dim c As Range
    Dim shn As String
    Dim id As Variant

    id = Application.InputBox("作成する社員IDを指定してください", Type:=2)
    If id = False Then Exit Sub 'キャンセルボタン

    Set c = Worksheets("賃金一覧").Columns("A").Find(What:=id, LookAt:=xlWhole)
    If c Is Nothing Then
        MsgBox "指定の社員IDはありません"
        Exit Sub
    End If

    shn = c.Offset(, 2).Value

    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets(shn).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    DoEvents    'おまじない
    With Worksheets(Worksheets.Count)
        .Range("M2").Value = c.Value
        .Range("T2").Value = c.Offset(, 1).Value
        .Range("AI1").Value = c.Offset(, 3).Value
        .Name = shn
    End With

 End Sub

（β） 2017/01/14(土) 09:45

 思い付きでコメントした入力規則でのＩＤ選択と自動実行の処理例です。
 以下のコードでは　入力規則セルを　賃金一覧の F1 にしています。　ここは★のところを変更すれば
 どのシートのどのセルでもＯＫです。

 なお、入力規則はマクロ内で自動的に設定しています。

 すべてを　ThisWorkbookモジュールに貼り付け、一度保存して閉じたうえで開き直してください。

 Option Explicit

 Const LISTNM As String = "賃金一覧"
 Const TPLTNM As String = "原本"
 Const RULEAD As String = LISTNM & "!F1"    '★入力規則設定セル

 Private Sub Workbook_Open()
    RuleSet
 End Sub

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = LISTNM Then
        If Not Intersect(Target, Sh.Columns("A:D")) Is Nothing Then RuleSet
    End If
    If Sh.Name = Range(RULEAD).Parent.Name Then
        If Not Intersect(Target, Range(RULEAD)) Is Nothing Then MakeSh
    End If
 End Sub

 Private Sub RuleSet()
    Dim ad As String

    With Sheets(LISTNM)
        ad = "=" & .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Address(External:=True)
    End With

    With Range(RULEAD).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ad
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With

 End Sub

 Private Sub MakeSh()
    Dim c As Range
    Dim shn As String
    Dim id As Variant

    If IsEmpty(Range(RULEAD)) Then Exit Sub

    id = Range(RULEAD).Value

    Set c = Worksheets(LISTNM).Columns("A").Find(What:=id, LookAt:=xlWhole)
    If c Is Nothing Then
        MsgBox "指定の社員IDはありません"
        Exit Sub
    End If

    Application.EnableEvents = False

    shn = c.Offset(, 2).Value

    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets(shn).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    Worksheets(TPLTNM).Copy After:=Worksheets(Worksheets.Count)
    DoEvents    'おまじない
    With Worksheets(Worksheets.Count)
        .Range("M2").Value = c.Value
        .Range("T2").Value = c.Offset(, 1).Value
        .Range("AI1").Value = c.Offset(, 3).Value
        .Name = shn
    End With

    Application.EnableEvents = True

 End Sub

（β） 2017/01/15(日) 10:58

βさん
社員ID指定のシート追加についてありがとうございました。
こちらも動作が無事確認ができました。
（御礼が週明けとなってしまい申し訳ありません。）

今まで、手作業で毎月行っていた時間を考えると本当にびっくりするほど簡易的になりました。
自分でも本を片手に調べていたのですが、何分組み立て方が全然できず、教えていただいたコードを見ると何となく何をしているのかが分かるけど、作り上げることができないという致命的な悩みで半年うろうろしてました。
入力規制セルの参考は分からないところがあるので、またじっくりコードなど見比べながら勉強させて頂きます。
本当にありがとうございました。
（marco3） 2017/01/16(月) 15:08

コメント返信：

[ 一覧(最新更新順) ]

[[20170113164036]] 『一覧からシートを順番に作成し、一覧から値を取得』（marco3） ページの最後に飛ぶ

[[20170113164036]]　『一覧からシートを順番に作成し、一覧から値を取得』（marco3）　ページの最後に飛ぶ