Mungkin script berikut bisa memberi ide solusi. Sesuaikan kembali dengan keadaan nyatanya. Private Sub Cmb_Generate_Click() Dim Rng As Range Dim sSht As String Dim W As Long, w1 As Long, aw As Long, hal As Long Dim lRecPerPage As Long, lTotalPage As Long
'aw = 0 'hal = 1 'init object kerja Set wadd = ActiveWorkbook Set Rng = wadd.Sheets(1).Range("b2") Set Rng = wadd.Sheets(1).Range(Rng, Rng.End(xlDown)) 'asumsi : tidak mungkin terjadi record berjumlah 0 'init konstanta sSht = "SPKL" lRecPerPage = 30 w1 = Rng.Rows.Count lTotalPage = w1 / lRecPerPage 'loop create page For W = 0 To w1 - 1 Step lRecPerPage 'If W Mod 30 = 0 Or w1 = 1 Then 'ThisWorkbook.Sheets("SPKL").Copy Before:=WAdd.Sheets(1) hal = hal + 1 'init page number With wadd 'drop existing sheet target On Error Resume Next If Not .Sheets(sSht & hal) Is Nothing Then Application.DisplayAlerts = False .Sheets(sSht & hal).Delete Application.DisplayAlerts = True End If Err.Clear On Error GoTo 0 'create new sheet target .Sheets(sSht).Copy after:=.Sheets(1) Set sadd = ActiveSheet sadd.Name = sSht & hal End With 'write page main fields With sadd .Range("i5") = cmb_area.Value .Range("i6") = txt_atasan.Value .Range("C6") = lbl_tgl.Caption .Range("C41") = w1 .Range("i60") = hal & " Dari " & lTotalPage End With 'init current page record count If W + lRecPerPage > w1 Then aw = w1 - W Else aw = lRecPerPage End If 'w1 = w1 + 1 'hal = hal + 1 'End If 'write data record If aw > 0 Then With sadd.Range("A10").Resize(aw) 'nomor urut .Formula = "=row()-9" .Calculate .Value = .Value .Offset(0, 2).Value = Format(txt_scan.Value, "'000000") .Offset(0, 5).Value = Left(txt_jam, 5) .Offset(0, 6).Value = Right(txt_jam, 5) End With End If 'aw = aw + 1 Next End Sub Kid. On Fri, Dec 2, 2011 at 09:27, ppc lambda <ppc...@sami.co.id> wrote: > ** > > Pagi para pakar & All member mohon bantuan lagi nich > saya membuat aplikasi sederhana, ketika di jalankan terjadi Debug dan > langsung meminta restart excel > coding > mohon koreksinya > Private Sub Cmb_Generate_Click() > Dim Rng As Range, W As Long, w1 As Long, aw As Long, hal As Long > w1 = 1 > aw = 0 > hal = 1 > Set WAdd = ActiveWorkbook > Set Rng = WAdd.Sheets(1).Range("b2") > Set Rng = WAdd.Sheets(1).Range(Rng, Rng.End(xlDown)) > > For W = 1 To Rng.Rows.Count > If W Mod 30 = 0 Or w1 = 1 Then > ThisWorkbook.Sheets("SPKL").Copy Before:=WAdd.Sheets(1) > Set SAdd = ActiveSheet > SAdd.Name = "SPKL" & hal > WAdd.Sheets(SAdd.Name).Range("i5") = cmb_area.Value > WAdd.Sheets(SAdd.Name).Range("i6") = txt_atasan.Value > WAdd.Sheets(SAdd.Name).Range("C6") = lbl_tgl.Caption > WAdd.Sheets(SAdd.Name).Range("C41") = Rng.Rows.Count > WAdd.Sheets(SAdd.Name).Range("i60") = (WorksheetFunction.Ceiling(W, 29) / > 29) _ > & " Dari " & (WorksheetFunction.Ceiling(Rng.Rows.Count, 29) / 29) > w1 = w1 + 1 > aw = 1 > hal = hal + 1 > End If > With WAdd.Sheets(SAdd.Name).Range("A10") > .Cells(aw, 1) = W > .Cells(aw, 3) = Format(txt_scan.Value, "'000000") > .Cells(aw, 6) = Left(txt_jam, 5) > .Cells(aw, 7) = Right(txt_jam, 5) > End With > aw = aw + 1 > Next > > End Sub > > Terimakasih > Best Regard > <>.<>.<>.<>.<>.<>. > Sidoel > >
<<Maize Bkgrd.jpg>>
<<amaizrul.gif>>