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))
'diganti menjadi
WAdd.Sheets("sheet1").Activate
Set Rng = ActiveSheet.Range("b2")
If Rng.Value = "" Then
MsgBox "data kosong"
Exit Sub
End If
Set Rng = ActiveSheet.Range(Rng, Rng.End(xlDown))
' batas pengantian For W = 1 To Rng.Rows.Count
' If W Mod 30 = 0 Or w1 = 1 Then
If W Mod 30 = 0 Or hal = 1 Then' supaya 30 baris ganti dng If
((W-1) Mod 30 = 0) Or hal = 1 Then
' ThisWorkbook.Sheets("SPKL").Copy Before:=WAdd.Sheets(1)
' Set SAdd = ActiveSheet
' SAdd.Name = "SPKL" & hal'diganti menjadi
On Error Resume Next
Worksheets("SPKL" & hal).Activate
If Err.Number = 9 Then
MsgBox "Error maka buat " & hal
ThisWorkbook.Sheets("SPKL").Copy Before:=WAdd.Sheets(1)
Set SAdd = ActiveSheet
SAdd.Name = "SPKL" & hal
Else
Set SAdd = ActiveSheet
End If
On Error GoTo 0
' batas pengantian
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 ' bisa digunakan hal saja
aw = 1
'isi tiap hal/sheet adalah 29
hal = hal + 1' agar isi sebelumnya dihapus
WAdd.Sheets(SAdd.Name).Range("A10").Select
Range(Selection, Selection.Offset(29, 9)).ClearContents
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
' baris berikutnya
aw = aw + 1
NextEnd Sub
To: belajar-excel@yahoogroups.com
From: ppc...@sami.co.id
Date: Mon, 5 Dec 2011 16:02:25 +0700
Subject: Re: [belajar-excel] Debug dan restart my workbook
Mr Kid setelah saya Replace code yang lama
dengan yang di buatkan Mr kid
ternyata masih error pada bagian ThisWorkbook.Sheets(sSht).Copy
before:=WAdd.Sheets(1)
mohon bantuannya para pakar Excel
Terimakasih
Best
Regard
<>.<>.<>.<>.<>.<>.
Sidoel
----- Original Message -----
From:
Kid Mr.
To: belajar-excel@yahoogroups.com
Sent: Monday, December 05, 2011 3:33
PM
Subject: Re: [belajar-excel] Debug dan
restart my workbook
hehehe...
ternyata ada attachment yang disusulkan.
Kira-kira
scriptnya demikian :
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").CurrentRegion
w1 =
Rng.Rows.Count - 1
If w1 < 1
Then
Exit
Sub
End If
Set Rng =
Rng.Offset(1).Resize(w1)
'init
konstanta
sSht = "SPKL"
lRecPerPage = 30
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
ThisWorkbook.Sheets(sSht).Copy
before:=WAdd.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 Mon, Dec 5, 2011 at 15:13, Kid Mr. <mr.nm...@gmail.com> wrote:
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
