返回列表 上一主題 發帖

[發問] 資料轉置貼上

回復 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

回復 8# 蘿蔔泥

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

TOP

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

回復 10# 蘿蔔泥


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

TOP

回復 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

TOP

回復  samwang


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


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

TOP

回復 20# 蘿蔔泥

上次寫的是將資料貼上步驟1>步驟2>步驟3
>> 上次寫的是由步驟1資料,轉成2的格式,且轉成3的格式,所以資料來源都是來自於 "1"
若資料是直接貼上步驟2,再由步驟2轉成步驟3呢?
>>這不就是和上次寫的結果一樣嗎?

TOP

回復  samwang


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


如何判斷資料來源是 1 還是 2 區域的資料?
如果2 個區域都有資料時要以哪個為主 ?

TOP

回復 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區都有資料時要以哪個為主??

TOP

不會兩個區域都有資料,只會有其中一個
蘿蔔泥 發表於 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
   

TOP

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


我狀況也是和您一樣,因為工作需要買書回來看,但是要應用就有點難度
最後自己在此網站看其他前輩的寫法後,自己要嘗試寫、多練習、遇到問題再詢問
加油 加油,謝謝

TOP

        靜思自在 : 是非當教育,讚美作警惕。
返回列表 上一主題