[發問] 製作簽到簿卡住了.......

dou10801

製作簽到簿卡住了,請前輩幫忙,我只會把第一張版面設定好,往下的版面如何處理,謝謝.

samwang

回復 1# dou10801

請測試看看，謝謝。

Sub test()
Dim Arr, Ar(1 To 27, 1 To 3), R%, C%, i&
Application.ScreenUpdating = False
Ar(1, 1) = "編 號": Ar(1, 2) = "姓 名": Ar(1, 3) = "簽 章"
R = 3: C = 5: N = 1
Arr = Range([會員資料!A1], [會員資料!B65536].End(3))
For i = 1 To UBound(Arr)
    N = N + 1: Ar(N, 1) = Arr(i, 1): Ar(N, 2) = Arr(i, 2)
    If N = 26 Then
        With Sheets("會員簽到簿").Cells(R, C).Resize(N, 3)
            .Value = Ar
            .Borders.LineStyle = xlContinuous
        End With
        C = C + 4: N = 1
    End If
    If C > 13 Then C = 5: R = R + 28
Next
If N > 1 Then
    With Sheets("會員簽到簿").Cells(R, C).Resize(N, 3)
        .Value = Ar
        .Borders.LineStyle = xlContinuous
    End With
End If
Application.ScreenUpdating = True
End Sub

dou10801

回復 2# samwang 感謝 samwang 前輩回覆,如何調整一頁是1-100,第二頁101-200....的頁面,如何設定為A3版面,橫向,感恩.

dou10801

回復 4# dou10801

samwang

回復 3# dou10801

如何調整一頁是1-100,第二頁101-200....的頁面>> 如下，請試看看，謝謝

Sub test2()
Dim Arr, Ar(1 To 27, 1 To 3), R%, C%, i&
Application.ScreenUpdating = False
Ar(1, 1) = "編 號": Ar(1, 2) = "姓 名": Ar(1, 3) = "簽 章"
R = 3: C = 5: N = 1
Arr = Range([會員資料!A1], [會員資料!B65536].End(3))
For i = 1 To UBound(Arr)
    N = N + 1: Ar(N, 1) = Arr(i, 1): Ar(N, 2) = Arr(i, 2)
    If N = 26 Then
        With Sheets("會員簽到簿").Cells(R, C).Resize(N, 3)
            .Value = Ar
            .Borders.LineStyle = xlContinuous
        End With
        C = C + 4: N = 1
    End If
    If C > 17 Then C = 5: R = R + 28  'C:填入資料位置(換頁)，可自行調整
Next
If N > 1 Then
    With Sheets("會員簽到簿").Cells(R, C).Resize(N, 3)
        .Value = Ar
        .Borders.LineStyle = xlContinuous
    End With
End If
Application.ScreenUpdating = True
End Sub

dou10801

回復 5# samwang 感謝,感謝.VBA版面自行修飾.

jcchiang

回復 1# dou10801

試試看
Sub ex()
Dim x%, y%, z%
For x = 1 To Sheets("會員資料").[a65535].End(3).Row Step 25
   With Sheets("會員簽到簿1")
      .[a3].Offset(y, z).Resize(, 3) = Array("編 號", " 姓名", "簽章")
      Cells(x, 1).Resize(25, 3).Copy .[a4].Offset(y, z)
      With .[a3].Offset(y, z).CurrentRegion
         .Borders.LineStyle = xlContinuous
      End With
      z = z + 4
      If z = 16 Then z = 0: y = y + 28
   End With
Next
End Sub

dou10801

回復 7# jcchiang 感恩,另一種思路,學習,學習.

dou10801

回復 7# jcchiang 請教 jcchiang 大大,如何將空隔填滿,謝謝.

下載 (109.74 KB)

2021-4-27 10:06

dou10801

回復 7# jcchiang

下載 (124.12 KB)

2021-4-27 10:08