123
返回列表 上一主題 發帖

[發問] 資料轉置貼上

蘿蔔泥

帖子
36 
主題
10 
精華
0 
積分
93 
點名
0  
作業系統
win10 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2018-2-27 
最後登錄
2022-2-25 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2021-10-15 15:19 | 只看該作者

[發問] 資料轉置貼上

各位大大好

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

我目前是用最笨的方法先從步驟一貼成步驟二，然後再轉成步驟三
不知道能不能寫成巨集，想請各位大大幫忙

轉置貼上.zip (19.53 KB)

收藏 分享

hcm19522

帖子
1387 
主題
4 
精華
0 
積分
1397 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-11-22 

熱烈參與勳章
2#
發表於 2021-10-15 16:25 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/590074872
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
3#
發表於 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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
4#
發表於 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

TOP

蘿蔔泥

帖子
36 
主題
10 
精華
0 
積分
93 
點名
0  
作業系統
win10 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2018-2-27 
最後登錄
2022-2-25 
5#
發表於 2021-11-1 11:49 | 只看該作者
謝謝各位，因為最近比較忙，我會找時間研究

TOP

蘿蔔泥

帖子
36 
主題
10 
精華
0 
積分
93 
點名
0  
作業系統
win10 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2018-2-27 
最後登錄
2022-2-25 
6#
發表於 2021-11-3 15:01 | 只看該作者
回復 3# samwang


謝謝，測試OK

TOP

蘿蔔泥

帖子
36 
主題
10 
精華
0 
積分
93 
點名
0  
作業系統
win10 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2018-2-27 
最後登錄
2022-2-25 
7#
發表於 2021-11-3 15:16 | 只看該作者
回復 4# 准提部林


  謝謝，測試OK

TOP

蘿蔔泥

帖子
36 
主題
10 
精華
0 
積分
93 
點名
0  
作業系統
win10 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2018-2-27 
最後登錄
2022-2-25 
8#
發表於 2021-11-3 15:44 | 只看該作者
還有一些問題想請教兩位大大

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

不好意思麻煩您了

轉置貼上.zip (50.08 KB)

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
9#
發表於 2021-11-3 16:39 | 只看該作者
回復 8# 蘿蔔泥

不好意思，不太能理解您的需求，可能需要另外詳細說明解釋，謝謝

TOP

蘿蔔泥

帖子
36 
主題
10 
精華
0 
積分
93 
點名
0  
作業系統
win10 
軟體版本
office 2007 
閱讀權限
20 
註冊時間
2018-2-27 
最後登錄
2022-2-25 
10#
發表於 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

TOP

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
123
返回列表 上一主題