Board logo

標題: [發問] 資料轉置貼上 [打印本頁]
作者: 蘿蔔泥    時間: 2021-10-15 15:19     標題: 資料轉置貼上

各位大大好

因工作上需要做到簽到表，但因來源格式都不相同所以每次都花很多間在做貼上值&轉置的動作

我目前是用最笨的方法先從步驟一貼成步驟二，然後再轉成步驟三
不知道能不能寫成巨集，想請各位大大幫忙
作者: hcm19522    時間: 2021-10-15 16:25

https://blog.xuite.net/hcm19522/twblog/590074872
作者: samwang    時間: 2021-10-15 16:41

回復 1# 蘿蔔泥

請測試看看，謝謝

Sub test()
Dim Arr, Brr(1 To 1000, 1 To 3), Crr()
Dim i&, j&, n%, s%, m%, R%
Arr = [n13].CurrentRegion  '來源資料1
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
End Sub
作者: 准提部林    時間: 2021-10-17 11:28

Sub test_1()
Dim Arr, Brr, i&, j&, T$, R&, C%
Range("a13:g2000").ClearContents
Arr = [n13].CurrentRegion
ReDim Brr(1 To 2000, 1 To 7)
For j = 1 To UBound(Arr, 2)
    For i = 1 To UBound(Arr)
        T = Arr(i, j): If T = "" Then GoTo i01
        C = C + 1: Brr(R + 1, C) = T
        If C = 7 Then C = 0: R = R + 1
i01: Next i
Next j
[a13].Resize(R + 1, 7) = Brr
End Sub
作者: 蘿蔔泥    時間: 2021-11-1 11:49

謝謝各位，因為最近比較忙，我會找時間研究
作者: 蘿蔔泥    時間: 2021-11-3 15:01

回復 3# samwang


謝謝，測試OK
作者: 蘿蔔泥    時間: 2021-11-3 15:16

回復 4# 准提部林


  謝謝，測試OK
作者: 蘿蔔泥    時間: 2021-11-3 15:44

還有一些問題想請教兩位大大

之前有寫一個巨集，不過有點亂不知道可不可以縮減或修改一下內容
一、依步驟2的內容依造人數多寡，挑選適合的簽到表貼上>>>>這個能改成從步驟三貼過去嗎？
二、依步驟3的內容貼到list>>>>目前卡到如果是全廠就要加上部門(部門-姓名)，但加上部門就無法從人員名單抓出工號與部門，能否寫成只抓姓名過去不抓部門呢？
三、人員名單的部分可以不增加灰色那一列就能抓取要的資訊嗎？

不好意思麻煩您了
作者: samwang    時間: 2021-11-3 16:39

回復 8# 蘿蔔泥

不好意思，不太能理解您的需求，可能需要另外詳細說明解釋，謝謝
作者: 蘿蔔泥    時間: 2021-11-3 16:53

回復 9# samwang


    不好意思，附件內容我有做更改
Sub 製作簽到表()

Dim a As Integer
a = Sheets("登錄(2)").Range("I9")
'MsgBox a

Sheets("list").Select
If Range("d2") = "" Then
   R = 2
Else
   R = Range("d1").End(xlDown).Row + 1
End If


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



Select Case a

    Case Is > 50
        Sheets("簽到記錄表 (3張)").Select
        If Sheets("簽到記錄表 (3張)").Range("A11") <> "" Then
           Sheets("簽到記錄表 (3張)").Range("A11:h48").ClearContents
        End If
        Range("b3") = Sheets("登錄(2)").Range("d7")
        Range("b4") = Sheets("登錄(2)").Range("b8")
        Range("h4") = Sheets("登錄(2)").Range("f9")
        Range("b6") = Sheets("登錄(2)").Range("e8")
        Range("b7") = Sheets("登錄(2)").Range("b9")
        Range("a11:a24") = Sheets("登錄(2)").Range("k13:k26").Value
        Range("h11:h24") = Sheets("登錄(2)").Range("k27:k40").Value
        Range("a25:a38") = Sheets("登錄(2)").Range("k41:k54").Value
        Range("h25:h38") = Sheets("登錄(2)").Range("k55:k68").Value
        Range("a39:a48") = Sheets("登錄(2)").Range("k69:k78").Value
        Range("h39:h48") = Sheets("登錄(2)").Range("k79:k88").Value

    Case Is > 24
        Sheets("簽到記錄表 (2張)").Select
        If Sheets("簽到記錄表 (2張)").Range("A11") <> "" Then
           Sheets("簽到記錄表 (2張)").Range("A11:h35").ClearContents
        End If
        Range("b3") = Sheets("登錄(2)").Range("d7")
        Range("b4") = Sheets("登錄(2)").Range("b8")
        Range("h4") = Sheets("登錄(2)").Range("f9")
        Range("b6") = Sheets("登錄(2)").Range("e8")
        Range("b7") = Sheets("登錄(2)").Range("b9")

        Range("a11:a24") = Sheets("登錄(2)").Range("k13:k26").Value
        Range("h11:h24") = Sheets("登錄(2)").Range("k27:k40").Value
        Range("a25:a35") = Sheets("登錄(2)").Range("k41:k51").Value
        Range("h25:h35") = Sheets("登錄(2)").Range("k52:k62").Value

    Case Is >= 0
        Sheets("簽到記錄表 (1張)").Select
        If Sheets("簽到記錄表 (1張)").Range("A11") <> "" Then
           Sheets("簽到記錄表 (1張)").Range("A11:h22").ClearContents
        End If
        Range("b3") = Sheets("登錄(2)").Range("d7")
        Range("b4") = Sheets("登錄(2)").Range("b8")
        Range("h4") = Sheets("登錄(2)").Range("f9")
        Range("b6") = Sheets("登錄(2)").Range("e8")
        Range("b7") = Sheets("登錄(2)").Range("b9")
        Range("a11:a22") = Sheets("登錄(2)").Range("k13:k24").Value
        Range("h11:h22") = Sheets("登錄(2)").Range("k25:k36").Value



End Select
End Sub
作者: samwang    時間: 2021-11-4 08:05

本帖最後由 samwang 於 2021-11-4 08:09 編輯

回復 10# 蘿蔔泥


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

回復 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
作者: 准提部林    時間: 2021-11-5 11:06

登錄表是"XXX-111", 人員名單是"111", 怎對得上???
作者: 蘿蔔泥    時間: 2021-11-5 13:45

回復 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這個函數，但就要在人員名單左邊重新貼一次姓名才能抓取右邊資料，
是否有其他函數能指定抓右邊或左邊哪一欄的資料呢？
作者: 蘿蔔泥    時間: 2021-11-5 13:50

回復 13# 准提部林

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

~~簽到記錄表 (2張)~~
打印頁是由上而下, 先左後右,
若剛好個數在25~28個之間,
第1頁14行: 左1~14, 右15~28,
第2頁12行, 是空白的!!!
作者: 准提部林    時間: 2021-11-6 10:43

先不管簽到頁數因增頁而有空白頁的問題
[attach]34350[/attach]

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

回復 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    時間: 2021-11-17 11:49

回復  samwang


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


不好意思，不太能理解，請附上檔說明，謝謝。
作者: 蘿蔔泥    時間: 2021-11-18 09:23

回復 19# samwang


    上次寫的是將資料貼上步驟1>步驟2>步驟3
    若資料是直接貼上步驟2，再由步驟2轉成步驟3呢？
作者: samwang    時間: 2021-11-18 10:15

回復 20# 蘿蔔泥

上次寫的是將資料貼上步驟1>步驟2>步驟3
>> 上次寫的是由步驟1資料，轉成2的格式，且轉成3的格式，所以資料來源都是來自於 "1"
若資料是直接貼上步驟2，再由步驟2轉成步驟3呢？
>>這不就是和上次寫的結果一樣嗎?
作者: 蘿蔔泥    時間: 2021-11-25 11:55

回復 17# 准提部林


    您好，謝謝您幫我改的，變的超級方便
    想請教您幾個函數的問題
    1.關於&或$與%，VBA書上沒出現過這個，不曉得是指什麼意思
    2.
      Dim MyArray(1 To 10, 5 To 15, 10 To 20)    ' Declare array variables.
      Upper = UBound(MyArray, 1)    ' Returns 10.
      Upper = UBound(MyArray, 3)    ' Returns 20.
      網路上只看過上面這種用法
      Arr = [n13].CurrentRegion      
      UBound(Arr, 2)>>>>這是指什麼意思呢？
   3.資料來源目前會有兩種，第一種是步驟1>步驟2>步驟3....這您上次有幫我解決
      若是第二種可直接貼上步驟2，並且登記到步驟3......可以改成如果步驟1是空格直接抓步驟2貼上步驟3嗎？
  1. Sub 資料轉置貼上()

  3. Dim Arr, Brr, i&, j&, T$, R&, C%
  4. Range("a13:g2000").ClearContents

  6. If Arr = [n13].CurrentRegion <> "" Then
  7. ReDim Brr(1 To 2000, 1 To 7)
  8. For j = 1 To UBound(Arr, 2)
  9.     For i = 1 To UBound(Arr)
  10.         T = Arr(i, j): If T = "" Then GoTo i01
  11.         C = C + 1: Brr(R + 1, C) = T
  12.         If C = 7 Then C = 0: R = R + 1
  13. i01: Next i
  14. Next j
  15. [a13].Resize(R + 1, 7) = Brr
  16. Else


  19. End Sub
複製代碼
作者: 蘿蔔泥    時間: 2021-11-25 11:58

回復 21# samwang


不好意思，我沒說清楚，
因為來源會有兩種格式，
如是步驟1的格式，流程就是步驟1>步驟2>步驟3
如是步驟2的格式，流程就是步驟2>步驟3
作者: samwang    時間: 2021-11-25 12:15

回復  samwang


不好意思，我沒說清楚，
因為來源會有兩種格式，
如是步驟1的格式，流程就是步驟1>步 ...
蘿蔔泥 發表於 2021-11-25 11:58


如何判斷資料來源是 1 還是 2 區域的資料?
如果2 個區域都有資料時要以哪個為主 ?
作者: samwang    時間: 2021-11-25 12:27

回復 22# 蘿蔔泥


  1.關於&或$與%，VBA書上沒出現過這個，不曉得是指什麼意思 >>可上網找一下就有，那些是 Dim 的簡寫 "&" = as Long
    2.
       Dim MyArray(1 To 10, 5 To 15, 10 To 20)    ' Declare array variables.
       Upper = UBound(MyArray, 1)    ' Returns 10.
       Upper = UBound(MyArray, 3)    ' Returns 20.
       網路上只看過上面這種用法
      Arr = [n13].CurrentRegion      
       UBound(Arr, 2)>>>>這是指什麼意思呢？ >> 取Arr的欄位數
   3.資料來源目前會有兩種，第一種是步驟1>步驟2>步驟3....這您上次有幫我解決
      若是第二種可直接貼上步驟2，並且登記到步驟3......可以改成如果步驟1是空格直接抓步驟2貼上步驟3嗎？ >> 2區都有資料時要以哪個為主??
作者: 蘿蔔泥    時間: 2021-11-25 13:34

如何判斷資料來源是 1 還是 2 區域的資料?
如果2 個區域都有資料時要以哪個為主 ?
samwang 發表於 2021-11-25 12:15



    不會兩個區域都有資料，只會有其中一個
作者: 蘿蔔泥    時間: 2021-11-25 13:37

回復  蘿蔔泥


  1.關於&或$與%，VBA書上沒出現過這個，不曉得是指什麼意思 >>可上網找一下就有，那些 ...
samwang 發表於 2021-11-25 12:27


請問VBA是哪個科系會學到呢？
我以前沒學過只是工作上需要，目前我都是自己買書回來學習，
很難學會怎應用，而且南部很少有這種課可以上，
是否有推薦的書籍可以看呢？
作者: samwang    時間: 2021-11-25 13:56

不會兩個區域都有資料，只會有其中一個
蘿蔔泥 發表於 2021-11-25 13:34


請再試看看，謝謝
Sub test2()
Dim Arr, Brr(1 To 1000, 1 To 3), Crr()
Dim i&, j&, n%, s%, m%, R%
If [n13] <> "" Then
    Arr = [n13].CurrentRegion  '來源資料1
    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
ElseIf [k13] <> "" Then
    Arr = Range([k13], [k65536].End(3)) '來源資料2
    For i = 1 To UBound(Arr)
        If Arr(i, 1) <> "" Then
            s = s + 1: Brr(s, 2) = Arr(i, 1)
        End If
    Next
End If

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
End Sub
   
作者: samwang    時間: 2021-11-25 14:08

請問VBA是哪個科系會學到呢？
我以前沒學過只是工作上需要，目前我都是自己買書回來學習，
很難學會怎 ...
蘿蔔泥 發表於 2021-11-25 13:37


我狀況也是和您一樣，因為工作需要買書回來看，但是要應用就有點難度
最後自己在此網站看其他前輩的寫法後，自己要嘗試寫、多練習、遇到問題再詢問
加油 加油，謝謝
作者: 准提部林    時間: 2021-11-25 16:58

Sub 資料轉置貼上()
Dim Arr, Brr, i&, j&, T$, R&, C%
Range("a13:g2000").ClearContents
If [k13] <> "" Then Arr = Range([k13], [k65536].End(xlUp)(2))
If [n13] <> "" Then Arr = [n13].CurrentRegion
ReDim Brr(1 To 2000, 1 To 7)
If Not IsArray(Arr) Then Brr(1, 1) = Arr: GoTo 999  '若資料只有一個~~ For j = 1 To UBound(Arr, 2)
For i = 1 To UBound(Arr)
        T = Arr(i, j): If T = "" Then GoTo i01
        C = C + 1: Brr(R + 1, C) = T
        If C = 7 Then C = 0: R = R + 1
i01: Next i
Next j
999: [a13].Resize(R + 1, 7) = Brr
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)