samwang

回復 10# 蘿蔔泥


不好意思，可能需要說明一下您的需求，不然光看您的程式碼就...，
另外，如果程式碼無問題且可功能正常，後學認為這樣就好，畢竟您自己寫的要修改或新增都容易
別人寫的要修改或新增就要花時間研究且不一定知道如何下手
謝謝

samwang

回復 10# 蘿蔔泥

只有作一些優化修改而已，規則條件都沒變更，請測試看看，謝謝

Sub 製作簽到表1()
Dim a%, sht, i%, j%
Set sht = Worksheets("登錄(2)")
With Sheets("list")
    For i = 13 To 27
        For j = 1 To 7
            R = .Range("d1").End(xlDown).Row + 1
            If sht.Cells(i, j) <> "" Then
                .Range("d" & R) = sht.Cells(i, j)
                .Range("e" & R) = sht.Range("b7")
                .Range("f" & R) = sht.Range("h7")
                .Range("g" & R) = sht.Range("d7")
                .Range("h" & R) = sht.Range("c7")
                .Range("i" & R) = sht.Range("g8")
                .Range("j" & R) = sht.Range("f10")
                .Range("k" & R) = sht.Range("e8")
                .Range("l" & R) = sht.Range("b8")
                .Range("n" & R) = "合格"
               If WorksheetFunction.CountIf(Sheets("人員名單").Range("a:a"), .Range("d" & R)) > 0 Then '大於0表示有找到這名員工
                    .Range("b" & R) = WorksheetFunction.VLookup(.Range("d" & R), Sheets("人員名單").Range("a:i"), 9, 0)
                    .Range("c" & R) = WorksheetFunction.VLookup(.Range("d" & R), Sheets("人員名單").Range("a:i"), 2, 0)
                Else                    
                    .Range("b" & R) = "缺"
                    .Range("c" & R) = "缺"
                End If
                .Range("a" & R) = .Range("c" & R) & .Range("e" & R) & .Range("l" & R)
                If WorksheetFunction.CountIf(.Range("a:a"), .Range("a" & R)) > 1 Then
                   .Range("p" & R) = "重複"
                End If
                R = R + 1
            End If
        Next
    Next
End With


a = sht.Range("I9")
Select Case a
     Case Is > 50
         With Sheets("簽到記錄表 (3張)")
            .Range("A11:h48").ClearContents
            .Range("b3") = sht.Range("d7")
            .Range("b4") = sht.Range("b8")
            .Range("h4") = sht.Range("f9")
            .Range("b6") = sht.Range("e8")
            .Range("b7") = sht.Range("b9")
            .Range("a11:a24") = sht.Range("k13:k26").Value
            .Range("h11:h24") = sht.Range("k27:k40").Value
            .Range("a25:a38") = sht.Range("k41:k54").Value
            .Range("h25:h38") = sht.Range("k55:k68").Value
            .Range("a39:a48") = sht.Range("k69:k78").Value
            .Range("h39:h48") = sht.Range("k79:k88").Value
        End With
     Case Is > 24
        With Sheets("簽到記錄表 (2張)")
            .Range("A11:h35").ClearContents
            .Range("b3") = sht.Range("d7")
            .Range("b4") = sht.Range("b8")
            .Range("h4") = sht.Range("f9")
            .Range("b6") = sht.Range("e8")
            .Range("b7") = sht.Range("b9")
            .Range("a11:a24") = sht.Range("k13:k26").Value
            .Range("h11:h24") = sht.Range("k27:k40").Value
            .Range("a25:a35") = sht.Range("k41:k51").Value
            .Range("h25:h35") = sht.Range("k52:k62").Value
         End With
     Case Is >= 0
        With Sheets("簽到記錄表 (1張)")
            .Range("A11:h22").ClearContents
            .Range("b3") = sht.Range("d7")
            .Range("b4") = sht.Range("b8")
            .Range("h4") = sht.Range("f9")
            .Range("b6") = sht.Range("e8")
            .Range("b7") = sht.Range("b9")
            .Range("a11:a22") = sht.Range("k13:k24").Value
            .Range("h11:h22") = sht.Range("k25:k36").Value
        End With
End Select
End Sub

准提部林

登錄表是"XXX-111", 人員名單是"111", 怎對得上???

蘿蔔泥

回復 11# samwang

不好意思我在寫詳細一點，麻煩您，謝謝。
目前作業流程是一、人員報名or指定人員"登錄(2)">>二、簽到表製作"簽到記錄表 (1張)or簽到記錄表 (2張)or簽到記錄表 (3張)">>三、登記人員上課紀錄"list"
現在巨集寫的方式:
先將登錄(2)步驟1轉換成步驟2再轉換成步驟3>>>然後依照登錄(2)步驟3的人數挑選要貼上的簽到表>>>再將登錄(2)步驟2的名單貼到list裡>>>將名字貼到list裡後有一個巨集會去人員名單抓這個人的工號與部門

問題一、可以將再將登錄(2)步驟2的名單貼到list裡改成由再將登錄(2)步驟3的名單貼到list裡嗎？
先將登錄(2)步驟1轉換成步驟2再轉換成步驟3>>>然後依照登錄(2)步驟3的人數挑選要貼上的簽到表>>>再將登錄(2)步驟3的名單貼到list裡

問題二、如果將有部門的姓名直接貼上list那後面那個巨集就無法抓這個人的工號與部門
舉例XXX部門-陳00可以只抓陳00貼上就好嗎？

問題三、在list的部分會依照抓過去的姓名去抓取人員工號與部門，目前在巨集裡用的是vlookup這個函數，但就要在人員名單左邊重新貼一次姓名才能抓取右邊資料，
是否有其他函數能指定抓右邊或左邊哪一欄的資料呢？

蘿蔔泥

回復 13# 准提部林

  就是這個有點困擾，因為如果是不同部門一起參加，主管會希望加上部門
  但抓過去後就無法比對正確，所以才想說有沒有辦法可以在貼上list時只抓取"-"之後的名子
  目前都是等貼上後再去手動修改與抓取資料

准提部林

~~簽到記錄表 (2張)~~
打印頁是由上而下, 先左後右,
若剛好個數在25~28個之間,
第1頁14行: 左1~14, 右15~28,
第2頁12行, 是空白的!!!

准提部林

先不管簽到頁數因增頁而有空白頁的問題
Xl0000798.rar (34.65 KB)

下載次數: 4

2021-11-6 10:39

1)匯入list及載入簽到表, 分開處理, 若要一次到位, 自己再弄個程序+call
2)list比對重覆, 應是"員編+日期"才對吧!  若有問題自行調整
3)簽到表只用一張工作表, 自動依個數增加頁數

蘿蔔泥

回復 3# samwang


您好，請問如果要跳過步驟1直接將名單貼在步驟2貼上，
再由步驟2的貼到步驟3我該如何修改呢？

Sub test2()
Dim Arr, Brr(1 To 1000, 1 To 3), Crr()
Dim i&, j&, n%, s%, m%, R%

Arr = [n13].CurrentRegion  '來源資料1
If Arr <> "" Then
For j = 1 To UBound(Arr, 2): For i = 1 To UBound(Arr)
    If Arr(i, j) <> "" Then
        If n < 7 Then n = n + 1 Else n = 1
        s = s + 1: Brr(s, 1) = n
        Brr(s, 2) = Arr(i, j): Brr(s, 3) = s
    End If
Next i: Next j
[j13].Resize(s, 3) = Brr   '轉貼到2
R = Int(s / 7) + 1: ReDim Crr(1 To R, 1 To 7): k = 1
For i = 1 To s
    For j = 1 To 7
        m = m + 1: If m > s Then GoTo 99
        Crr(i, j) = Brr(m, 2)
    Next
99: Next i
Range("a13").Resize(R, 7) = Crr  '轉貼到3


Else

Range("a13").Resize(R, 7) = Crr  '轉貼到3

End If
End Sub

samwang

回復  samwang


您好，請問如果要跳過步驟1直接將名單貼在步驟2貼上，
再由步驟2的貼到步驟3我該如何 ...
蘿蔔泥 發表於 2021-11-17 10:54

不好意思，不太能理解，請附上檔說明，謝謝。

蘿蔔泥

回復 19# samwang


    上次寫的是將資料貼上步驟1>步驟2>步驟3
    若資料是直接貼上步驟2，再由步驟2轉成步驟3呢？