標題: [發問] 製作簽到簿卡住了....... [打印本頁]

---

作者: dou10801    時間: 2021-4-23 08:32     標題: 製作簽到簿卡住了.......

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

---

作者: samwang    時間: 2021-4-23 13:00

回復 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    時間: 2021-4-23 14:37

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

---

作者: dou10801    時間: 2021-4-23 14:40

回復 4# dou10801

---

作者: samwang    時間: 2021-4-23 14:59

回復 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    時間: 2021-4-23 16:05

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

---

作者: jcchiang    時間: 2021-4-23 21:04

回復 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    時間: 2021-4-26 07:56

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

---

作者: dou10801    時間: 2021-4-27 10:08

回復 7# jcchiang 請教 jcchiang 大大,如何將空隔填滿,謝謝.[attach]33259[/attach]

---

作者: dou10801    時間: 2021-4-27 10:08

回復 7# jcchiang [attach]33260[/attach]

---

作者: dou10801    時間: 2021-4-27 14:07

回復 7# jcchiang 每頁剛好1-100,第二頁101-200....以此類推,本範例到443筆,畫空格線到500,剛好一頁,謝謝.

---

作者: jcchiang    時間: 2021-4-27 18:41

回復 11# dou10801

Sub ex()
Dim x%, y%, z%
For x = 1 To WorksheetFunction.RoundUp(Sheets("會員資料").[a65535].End(3).Row / 100, 0) * 100 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).Resize(26, 3)
         .Borders.LineStyle = xlContinuous
      End With
      z = z + 4
      If z = 16 Then z = 0: y = y + 28
   End With
Next
End Sub

---

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