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 <[email protected]> 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>>
