Re: [belajar-excel] Debug dan restart my workbook

[ppc lambda]

trimakasih Mr Kid akan saya aplikasikan di tempat ku


Terimakasih
Best Regard
<>.<>.<>.<>.<>.<>.
Sidoel
  ----- Original Message ----- 
  From: Kid Mr. 
  To: belajar-excel@yahoogroups.com 
  Sent: Monday, December 05, 2011 3:13 PM
  Subject: Re: [belajar-excel] Debug dan restart my workbook


    
  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




  

<<amaizrul.gif>>