[[20200804061220]]　『回覧簿を作成したい』（よっちゃん）　ページの最後に飛ぶ

『回覧簿を作成したい』（よっちゃん）

B1～K1、B4～、B7～
名前　
B2～K1、B5～、B8～
空欄

と、なっていて空欄セルは捺印ができる程度の列幅
になっています。

しかし、メンバーが増えてそのたびに変更作業が発生します。
後ろに、追加であれば特に問題ないのですがB1とC1の間に増えて
それ以降の部分がズレる等結構手間です。
部内は、25人程います。

別シートで、メンバー表を作成して追加したい場所へ追加し回覧簿にも
その順番で反映してくれるようなやり方何かありませんか？

関数かマクロで、実現出来たらうれしいのですが。。
宜しくお願い致します。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

＞B2～K1、B5～、B8～
たぶん、B2～K【2】、B5～、B8～　ですよね。

お悩みのほうは、詰まっているよくわかりませんが、1、4、7行目にそれぞれ行挿入を行ったうえで、VLOOKUPなどで参照したらどうですか？

 「メンバー表」シート
  ____A_____B______
 1  番号  名前
 2    1   あああ
 3    2   いいい
 4    3   ううう
 5    4   えええ
 6    5   おおお
 7    6   かかか
 8    7   ききき
 9    8   くくく

 表示用のシート
  ___A_____B_______C______D___....
 1         1       2      3
 2 名前    ★ →
 3 押印欄
 4
 5         11      12     13
 6 名前    ◆ →
 7 押印欄

 (1)  ★のところに、↓を書き込んで、K列までコピー
      =VLOOKUP(B1,メンバー表!$A$1:$B$25,2,FALSE)

 (2)  ◆のところに、B2～K2を貼付

 (3)　1,5,9行目（挿入した行）を非表示にする

（もこな２） 2020/08/04(火) 07:40

 こんにちは　＾＾
お望みのフォーマットがよく解りませんでしたので。。。←　私だけ　＾＾；
恐怖の憶測と推測の域を出ない超エスパー的デモコードですが、ご考察の一助
にでも、なれば幸甚です。外しておりましたらポイしてくださいね。(￣▽￣)
何分、あちこち、消しまくるコードも含んでおりますので、お試の際には、
新規ブックにてお願いいたします。幽霊変数等有るやも知れませんが、何卒お
目こぼしを。m(_ _)m...でわでわ
Option Explicit
Sub OneInstanceMain()
    Const zProgramID  As String = "IJ00060.xlsm"
    Dim zTb           As Workbook
    Dim i             As Long
    Dim y             As Long
    Dim x             As Long
    Dim dan           As Long
    Dim retu          As Long
    Dim v()           As Variant
    Dim rn()          As Variant
    Dim t             As Double
    t = Timer
    zDummymMasterMake
    dan = 3
    retu = 10
    Set zTb = Workbooks(zProgramID)
    With zTb.Worksheets("zXjejeMaster")
        Intersect(.UsedRange, .Columns("A:B")).Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
        v = Intersect(.UsedRange, .Columns("A:B")).Value
    End With
    ReDim rn(1 To 4 * dan, 1 To 1 * retu)
    y = 1: i = 1
    Do
        For x = 1 To UBound(rn, 2)
            rn(y, x) = v(i, 2)
            i = i + 1
            If i > UBound(v, 1) Then Exit Do
        Next
        y = y + 4
        DoEvents
    Loop
    With zTb.Worksheets("Sheet1")
        .UsedRange.Clear
        .Cells(1).Resize(UBound(rn, 1), UBound(rn, 2)) = rn
        .UsedRange.Columns.AutoFit
        .Activate
    End With
    Set zTb = Nothing
    Erase v, rn
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Sub zDummymMasterMake()
    Dim sNm                 As String
    Dim i                   As Long
    Dim v(1 To 25, 1 To 2)  As Variant
    For i = 1 To 25
        v(i, 1) = 10000 + i
        v(i, 2) = "従業員-" & Split(Cells(i).Address, "$")(1)
    Next
    sNm = "zXjejeMaster"
    If Not Evaluate("=ISREF(" & sNm & "!A1)") Then Sheets.Add.Name = sNm
    With Worksheets(sNm)
        .UsedRange.Clear
        .Cells(1).Resize(UBound(v, 1), UBound(v, 2)) = v
        .UsedRange.Columns.AutoFit
    End With
End Sub
（隠居じーさん） 2020/08/04(火) 08:25

追伸。。。お解りの事とはぞんじますが、新規ブックを
IJ00060.xlsm
で保存してくださいませ。後、サブルーチンのブック指定を失念致しており
中途半端なコードになっております。他のブックを同じプロセスから開いて
いなければ問題は無いと思いますので、ご必要でしたらご修正お願いいたし
ます。m(_ _)m

（隠居じーさん） 2020/08/04(火) 08:35

Sub main()

    'シート名＝回覧簿、メンバー表の２シート構成
    'メンバー表のA列に氏名列挙
    Dim ws1 As Worksheet, ws2 As Worksheet, c As Range, r As Range
    Set ws1 = Sheets("回覧簿")
    Set ws2 = Sheets("メンバー表")
    ws1.Range("B:H").ClearContents
    Set r = ws1.Range("B1")
    For Each c In ws2.Range("A:A").SpecialCells(2)
        r.Value = c.Value
        If r.Column = 11 Then
            Set r = r.Offset(3, -9)
        Else
            Set r = r.Offset(, 1)
        End If
    Next c
End Sub
（mm） 2020/08/04(火) 09:39

仮にマクロでやるにしても、単純に行列を入れ替えて貼付を必要な分繰り返せば事足りませんか？

    Sub さんぷる()
        Dim i As Long

        With Worksheets("メンバー表")
            For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row Step 10
                .Cells(i, "B").Resize(10, 1).Copy

                Worksheets("回覧簿").Range("B1").Offset((i \ 10) * 3).PasteSpecial _
                Paste:=xlPasteValues, Transpose:=True
            Next i
        End With
    End Sub

（もこな２） 2020/08/04(火) 12:53

もなこ２　さん

コードありがとうございます。

やってみたのですが、希望通りには作成出来るのですが次セルが空白の場合に
コピー範囲とペースト範囲が選択された状態で終了してまいます。

これは、解除した状態で終了するのは無理なのでしょうか？？？
（よっちゃん） 2020/08/10(月) 15:09

＞これは、解除した状態で終了するのは無理なのでしょうか？？？
たぶん私宛だと思うのでコメントしますが、無理じゃないです。

最後にコピーカットモードを解除して、適当なセルを選択すれば可能です。
（いずれもマクロの記録を使えばコードは容易にわかります）

ただ、自分では一切考えたくないということであればマクロはお勧めしません。
メンテナンスできずに泣きつかれても困りますので・・・

（もこな２） 2020/08/10(月) 19:20

コメント返信：

[ 一覧(最新更新順) ]

[[20200804061220]] 『回覧簿を作成したい』（よっちゃん） ページの最後に飛ぶ

[[20200804061220]]　『回覧簿を作成したい』（よっちゃん）　ページの最後に飛ぶ