[belajar-excel] Digest Number 1423

Milis Belajar Microsoft Excel

Messages In This Digest (24 Messages)

1a.

Re: Week berdasar sel tanggal dan Bulan From: agung_widodo@sanyo.com

1b.

Re: Week berdasar sel tanggal dan Bulan From: Haps

2a.

Re: Debug dan restart my workbook From: ppc lambda

2b.

Re: Debug dan restart my workbook From: ppc lambda

2c.

Re: Debug dan restart my workbook From: Kid Mr.

2d.

Re: Debug dan restart my workbook From: Kid Mr.

2e.

Re: Debug dan restart my workbook From: ppc lambda

2f.

Re: Debug dan restart my workbook From: jkssxls Sudarsono

3a.

Re: Masalah Lookup yang rumit From: Mansor

3b.

Re: Masalah Lookup yang rumit From: jkssxls Sudarsono

4a.

Re: ListBox Multi Selection From: Onto Seno

5a.

Dynamic row From: "andre"

5b.

Re: Dynamic row From: Kid Mr.

5c.

Bls: [belajar-excel] Dynamic row From: ghozi alkatiri

6a.

Re: mengunci cell terisi di validation From: Onto Seno

7a.

Replace Data Perbaris From: muja

7b.

Re: Replace Data Perbaris From: Onto Seno

8a.

Apa Perbedaan Format Save As Binary dg Save As lainnya From: PT. ADHI KARYA (PERSERO) Tbk

8b.

Re: Apa Perbedaan Format Save As Binary dg Save As lainnya From: Onto Seno

9a.

Fungsi Drop down list plus vlookup From: harry budiman

9b.

Re: Fungsi Drop down list plus vlookup From: Onto Seno

9c.

Re: Fungsi Drop down list plus vlookup From: harbudiman@gmail.com

9d.

Bls: [belajar-excel] Re: Fungsi Drop down list plus vlookup From: ghozi alkatiri

9e.

Re: Bls: [belajar-excel] Re: Fungsi Drop down list plus vlookup From: harbudiman@gmail.com

View All Topics | Create New Topic

Messages

1a.

Re: Week berdasar sel tanggal dan Bulan

Posted by: "agung_widodo@sanyo.com" agung_widodo@sanyo.com

Mon Dec 5, 2011 12:56 am (PST)

Sudah bisa Mr Kid.

Terimakasih pak Udin atas rintisan formulanya
Terimakasih Mas Kid atas solusinya.

Wassalam
Agung W.

________________________________
From: belajar-excel@yahoogroups.com [mailto:belajar-excel@yahoogroups.com] On Behalf Of Kid Mr.
Sent: Monday, December 05, 2011 3:45 PM
To: belajar-excel@yahoogroups.com
Subject: Re: [belajar-excel] Week berdasar sel tanggal dan Bulan

Coba angka 13 diganti dengan 1 (jika hari pertama sebuah week adalah minggu), dan 2 jika mulai senin.
Berurusan dengan week number dalam setahun, harus memiliki kriteria yang jelas titik start yang disebut week pertama sebuah tahun.

Selamat mencoba,
Kid.
2011/12/5 <agung_widodo@sanyo.com<mailto:agung_widodo@sanyo.com>>

Mohon maaf pak Udin,
Tampaknya belum bisa.

________________________________
From: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> [mailto:belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com>] On Behalf Of Udin Haeruddin
Sent: Monday, December 05, 2011 1:58 PM
To: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com>
Subject: Re: [belajar-excel] Week berdasar sel tanggal dan Bulan

Coba
=WEEKNUM(DATE(YEAR(B2),MONTH(B2),A2),13)

--
====== Haeruddin, S.Pd ======

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (6)

1b.

Re: Week berdasar sel tanggal dan Bulan

Posted by: "Haps" hapsari.stlizbeth@gmail.com   liz_hap

Mon Dec 5, 2011 5:06 am (PST)

Sudah terlambat ya...

Asumsinya: kolom MONTH = *data date* yg hanya ditampakkan MMM-YY nya
Angka-Tanggal nya biasanya = 1; tetapi kita tidak mau ambil risiko maka
kita haruskan jadi tgl [SEBELUM SATU] 1 dulu

=B2 - Day(B2) + A2

Tafsisr Al Haps:
*Data date di B2 dimundurkan sebanyak nilai ANGKA TANGGAL-nya *
*(hasilnya pasti tgl sebelum **tgl 1 bulan itu) *
*lalu ditambah bilangan yg ada di A2*

Sekali lagi data di kolom B (month) harus daa tanggal, apapun format
tampilnya

2011/12/5 <agung_widodo@sanyo.com>

> **
>
> Mohon maaf pak Udin,****
>
> Tampaknya belum bisa.****
>
> ** **
>
> ****
>
> ** **
>
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (6)

2a.

Re: Debug dan restart my workbook

Posted by: "ppc lambda" ppc_03@sami.co.id

Mon Dec 5, 2011 12:57 am (PST)

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_03@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

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (17)

2b.

Re: Debug dan restart my workbook

Posted by: "ppc lambda" ppc_03@sami.co.id

Mon Dec 5, 2011 1:02 am (PST)

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.nmkid@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

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (17)

2c.

Re: Debug dan restart my workbook

Posted by: "Kid Mr." mr.nmkid@gmail.com   nmkid.family@ymail.com

Mon Dec 5, 2011 1:11 am (PST)

Nama sheet di baris
sSht = "SPKL"
disesuaikan jadi spki atau apa itu yang anda miliki.

Kid.

On Mon, Dec 5, 2011 at 16:02, ppc lambda <ppc_03@sami.co.id> wrote:

> **
>
>
> **
>
> 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. <mr.nmkid@gmail.com>
> *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.nmkid@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
>
>
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (17)

2d.

Re: Debug dan restart my workbook

Posted by: "Kid Mr." mr.nmkid@gmail.com   nmkid.family@ymail.com

Mon Dec 5, 2011 1:13 am (PST)

Mumpung sempat kirim workbook,

Kid.

On Mon, Dec 5, 2011 at 16:11, Kid Mr. <mr.nmkid@gmail.com> wrote:

> Nama sheet di baris
> sSht = "SPKL"
> disesuaikan jadi spki atau apa itu yang anda miliki.
>
> Kid.
>
>
> On Mon, Dec 5, 2011 at 16:02, ppc lambda <ppc_03@sami.co.id> wrote:
>
>> **
>>
>>
>> **
>>
>> 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. <mr.nmkid@gmail.com>
>> *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.nmkid@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
>>
>>
>>
>>
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (17)

2e.

Re: Debug dan restart my workbook

Posted by: "ppc lambda" ppc_03@sami.co.id

Mon Dec 5, 2011 1:36 am (PST)

Mr kid saya coba Workbook yang di lampirkan masih terjadi error di tempat dan problem yang sama
para pakar yang lain mohon pencerahannya

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

Mumpung sempat kirim workbook,

Kid.

On Mon, Dec 5, 2011 at 16:11, Kid Mr. <mr.nmkid@gmail.com> wrote:

Nama sheet di baris
sSht = "SPKL"
disesuaikan jadi spki atau apa itu yang anda miliki.

Kid.

On Mon, Dec 5, 2011 at 16:02, ppc lambda <ppc_03@sami.co.id> wrote:

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.nmkid@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

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (17)

2f.

Re: Debug dan restart my workbook

Posted by: "jkssxls Sudarsono" jkssxls@hotmail.com   jkssbma

Mon Dec 5, 2011 1:39 am (PST)

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_03@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.nmkid@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

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (17)

3a.

Re: Masalah Lookup yang rumit

Posted by: "Mansor" dbpermatasari@gmail.com   nbmy1980

Mon Dec 5, 2011 1:02 am (PST)

Pak Sudarsono,

Kode macro yang kedua ada Compile error message " Sub or function not
define "

Saya udah coba debug namun tidak berhasil.
Mohon sekali lag bantuan bapak.

Terima kasih

-Mansor

2011/12/2 jkssxls Sudarsono <jkssxls@hotmail.com>

> **
>
>
> Option Base 1
> Dim kdAccLedger As Long
> Dim kdAccCustomer As Long
> Dim urutTrans As Long
> Sub testing()
> 'tambahkan no urut transaksi
> urutTrans = 0
> kdAccLedger = 871814
> kdAccCustomer = 6932942
> '====
>
> Call telusuriData(Worksheets("Sheet1").Range("A32:J42"),
> Worksheets("Sheet2").Range("a13"))
> End Sub
> Function telusuriData(daerahku As Range, tujuannya As Range)
> m_NoReferensi = ""
> Dim kolstr_Tanggal, kolnum_Debet, kolNum_kredit, kolstr_NoReference As
> Integer
> kolstr_Tanggal = 1
> kolstr_Deskripsi = 2
> kolnum_Debet = 3
> kolNum_kredit = 4
> kolstr_NoReference = 7
> kolStr_Remark = 10
> Dim sel As Range
>
> Dim Arr_Simpan() As Variant
> Dim jumItem As Integer
> jumItem = 0
> For Each sel In daerahku.Rows
> isiNoReferensi = sel.Resize(1, 1).Offset(0, kolstr_NoReference - 1).Value
> ' jika ada perubahan no reference
> If m_NoReferensi <> isiNoReferensi Then
> If m_NoReferensi <> "" Then
> ' jika no referensi sbelumnya tak kosong
> Call sortArray_2D(Arr_Simpan, 1)
> Call hilangkantambahan(Arr_Simpan, 1)
> Call TambahanZZ(Arr_Simpan, 1)
> Call SimpanKetujuan(Arr_Simpan, tujuannya)
> End If
> m_NoReferensi = sel.Resize(1, 1).Offset(0, kolstr_NoReference - 1).Value
> jumItem = 0
> ReDim Arr_simpam(1, 1)
> End If
> If isiNoReferensi <> "" Then
> jumItem = jumItem + 1
> ReDim Preserve Arr_Simpan(7, jumItem)
> '1--> posting key
> '2--> Amount
> '3--> MM atau ZZ
> '4--> Transaction Date
> '5--> No Reference
> '6--> Remark
> '7--> Acc No , dari mana
> If sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value > 0 Then
> Arr_Simpan(2, jumItem) = sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value
> Else
> Arr_Simpan(2, jumItem) = sel.Resize(1, 1).Offset(0, kolNum_kredit -
> 1).Value
> End If
> If UCase(Trim(sel.Resize(1, 1).Offset(0, kolstr_Deskripsi - 1).Value)) =
> "TOTAL" Then
> Arr_Simpan(3, jumItem) = "MM"
> ' untuk total sisi Bank debet ( 31 ) perusahaan Kredit ( 25 )
> If sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value > 0 Then
> Arr_Simpan(1, jumItem) = 25 & "_" & "0"
> Else
> Arr_Simpan(1, jumItem) = 31 & "_" & "0"
> End If
> isiTanggal = sel.Resize(1, 1).Offset(0, kolstr_Tanggal - 1).Value
> isiNoReference = sel.Resize(1, 1).Offset(0, kolstr_NoReference - 1).Value
>
> Else
> ' sisi Bank debet ( 25 ) perusahaan Kredit ( 31 )
> Arr_Simpan(3, jumItem) = ""
> If sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value > 0 Then
> Arr_Simpan(1, jumItem) = 31 & "_" & jumItem
> Else
> Arr_Simpan(1, jumItem) = 25 & "_" & jumItem
> End If
> isiTanggal = ""
> isiNoReference = ""
> End If
> ' tak perlukan lagi
> Arr_Simpan(4, jumItem) = isiTanggal
> Arr_Simpan(5, jumItem) = isiNoReference
>
> Arr_Simpan(6, jumItem) = sel.Resize(1, 1).Offset(0, kolStr_Remark -
> 1).Value
> ' Arr_Simpan(7, jumItem) = "" ' diisi dari mana ?
> Arr_Simpan(7, jumItem) = kdAccCustomer
>
> End If
> labloop:
> Next
> Call sortArray_2D(Arr_Simpan, 1)
> Call hilangkantambahan(Arr_Simpan, 1)
> Call TambahanZZ(Arr_Simpan, 1)
> Call SimpanKetujuan(Arr_Simpan, tujuannya)
> End Function
> Sub sortArray_2D(MyArray, posisikey)
> jumkol = UBound(MyArray, 1)
> Dim kel1 As Variant
> Dim kel2 As Variant
> ReDim kel1((jumkol))
> ReDim kel2((jumkol))
> For lLoop = 1 To UBound(MyArray, 2)
> For lLoop2 = lLoop To UBound(MyArray, 2)
> If UCase(MyArray(posisikey, lLoop2)) < UCase(MyArray(posisikey, lLoop))
> Then
> For i = 1 To UBound(MyArray, 1)
> kel1(i) = MyArray(i, lLoop)
> kel2(i) = MyArray(i, lLoop2)
> MyArray(i, lLoop) = kel2(i)
> MyArray(i, lLoop2) = kel1(i)
> Next End If Next lLoop2
> Next lLoop
> End Sub
> Sub hilangkantambahan(MyArray, posisikey)
> For j = 1 To UBound(MyArray, 2)
> strnya = MyArray(posisikey, j)
> strnya = StrReverse(strnya)
> posisi = InStr(1, strnya, "_")
> If posisi > 0 Then
> strnya = Mid(strnya, posisi + 1)
> End If
> strnya = StrReverse(strnya)
> MyArray(posisikey, j) = strnya
> Next j
> End SubSub TambahanZZ(MyArray, posisikey)
>
> '1--> posting key
> '2--> Amount
> '3--> MM atau ZZ
> '4--> Transaction Date
> '5--> No Reference
> '6--> Remark
> '7--> Acc No , dari mana
> ' MM ZZ
> ' 25 25
> ' 50
> ' 31 31
> ' 40
> jumItem = UBound(MyArray, 2)
> For j = 1 To jumItem
> If j = 1 And MyArray(3, j) = "MM" Then
> mPostingKey = MyArray(posisikey, j)
> mAmount = MyArray(2, j)
> mdoc = "ZZ"
> mTanggal = MyArray(4, j)
> mReferenceNo = MyArray(5, j)
> mRemark = MyArray(6, j)
> mAccNo = MyArray(7, j)
> End If
> Next j
> ReDim Preserve MyArray(7, jumItem + 1)
> MyArray(posisikey, jumItem + 1) = mPostingKey
> MyArray(2, jumItem + 1) = mAmount
> MyArray(3, jumItem + 1) = mdoc
> MyArray(4, jumItem + 1) = mTanggal
> MyArray(5, jumItem + 1) = mReferenceNo
> MyArray(6, jumItem + 1) = mRemark
> MyArray(7, jumItem + 1) = kdAccCustomer
>
> If mPostingKey = 25 Then
> mPostingKey = 50
> ElseIf mPostingKey = 31 Then
> mPostingKey = 40
> Else
> mPostingKey = ""
> End If
> jumItem = jumItem + 1
> ReDim Preserve MyArray(7, jumItem + 1)
> MyArray(posisikey, jumItem + 1) = mPostingKey
> MyArray(2, jumItem + 1) = mAmount
> MyArray(3, jumItem + 1) = "" ' mdoc
> ' MyArray(4, jumItem + 1) = mTanggal
> MyArray(4, jumItem + 1) = ""
> ' MyArray(5, jumItem + 1) = mReferenceNo
>
> MyArray(5, jumItem + 1) = ""
> MyArray(6, jumItem + 1) = mRemark
> ' MyArray(7, jumItem + 1) = mAccNo
> MyArray(7, jumItem + 1) = kdAccLedger
>
> End Sub
> Sub SimpanKetujuan(MyArray, Tujuan As Range)
> Dim pjumItem As Integer
> '1--> posting key
> '2--> Amount
> '3--> Doc Type : MM atau ZZ
> '4--> Transaction Date
> '5--> No Reference
> '6--> Remark
> '7--> Acc No , dari mana
> '====
> ' Tanggal Doc-Type ReferenceNo PostingKey AccNo Amount Remark
> pjumItem = UBound(MyArray, 2)
> For j = 1 To pjumItem
> 'tambahkan no urut transaksi
> If MyArray(3, j) <> "" Then
> urutTrans = urutTrans + 1
> Tujuan.Offset(j - 1, 0).Value = urutTrans
> End If
>
> Tujuan.Offset(j - 1, 1).Value = MyArray(4, j)
> Tujuan.Offset(j - 1, 2).Value = MyArray(3, j)
> Tujuan.Offset(j - 1, 3).Value = MyArray(5, j)
> Tujuan.Offset(j - 1, 4).Value = MyArray(1, j)
> Tujuan.Offset(j - 1, 5).Value = MyArray(7, j)
> Tujuan.Offset(j - 1, 6).Value = MyArray(2, j)
> Tujuan.Offset(j - 1, 7).Value = MyArray(6, j)
> Next j
> Set Tujuan = Tujuan.Offset(pjumItem, 0)
> End Sub
>
> > To: belajar-excel@yahoogroups.com
> > From: dbpermatasari@gmail.com
> > Date: Fri, 2 Dec 2011 16:32:07 +0800
>
> > Subject: Re: [belajar-excel] Masalah Lookup yang rumit
> >
> > Pak Sudarsono,
> >
> > Menurut saya hasilnya udah 95% memenuhi kebutuhan saya.
> > (1) Yang kurang hanya sedikit, di kolom yang kosong maunya diisi no
> account
> > yang tetap yaitu 6932942.mungkin boleh disebut di makro Acc No = 6932942.
> > Bagitu juga GL 871814 adalah tetap dan tidak berubah, dan polanya tetap
> > sama seperti posisi di table asli di bawah.
> >
> > (2) Di kolom pertama sebelum tanggal ada nomor urut. Polanya no 1 berada
> di
> > baris yang sama dgn MM, no 2 di baris ZZ, no 3 MM semula, bagitulah
> > seterusnya no 4 ZZ.
> >
> > (3) Tanggal hanya ditulis dua kali sahaja yaitu sebaris dgn MM dan
> sebaris
> > dgn ZZ, yang lain dikosongkan sama seperti MM dan ZZ.
> >
> > 4) Selain untuk tujuan upload data ke sistem SAP, Table ini juga
> > berfungsi sebagai filter kepada Table statement dari bank, sebab data
> dari
> > bank bertambah setiap hari, tapi yang mau di lihat hanya data dari
> tanggal
> > tertentu sahaja.. Mungkin supaya lebih user friendly, tanggalnya bisa
> > diselect contohnya
> >
> > Tanggal dari 18 Nov 2011 hingga 23 Nov 2011 atau hanya satu tanggal
> sahaja
> > e.g 24 Nov 2011, maka yang muncul hanyalah tanggal yang diperlukan
> sahaja.
> >
> > Terima kasih sekali lagi atas bantuan bapak.
> >
> > -Mansor.
>
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (11)

3b.

Re: Masalah Lookup yang rumit

Posted by: "jkssxls Sudarsono" jkssxls@hotmail.com   jkssbma

Mon Dec 5, 2011 1:46 am (PST)

End SubSub TambahanZZ(MyArray, posisikey)
seharusnya di pisah jadi : End Sub Sub TambahanZZ(MyArray, posisikey)

To: belajar-excel@yahoogroups.com
From: dbpermatasari@gmail.com
Date: Mon, 5 Dec 2011 17:01:39 +0800
Subject: Re: [belajar-excel] Masalah Lookup yang rumit

Pak Sudarsono,

Kode macro yang kedua ada Compile error message " Sub or function not define "

Saya udah coba debug namun tidak berhasil.
Mohon sekali lag bantuan bapak.

Terima kasih

-Mansor






2011/12/2 jkssxls Sudarsono <jkssxls@hotmail.com>

Option Base 1
Dim kdAccLedger As Long
Dim kdAccCustomer As Long
Dim urutTrans As Long
Sub testing()
'tambahkan no urut transaksi
urutTrans = 0
kdAccLedger = 871814
kdAccCustomer = 6932942

'====

Call telusuriData(Worksheets("Sheet1").Range("A32:J42"), Worksheets("Sheet2").Range("a13"))
End Sub
Function telusuriData(daerahku As Range, tujuannya As Range)
m_NoReferensi = ""

Dim kolstr_Tanggal, kolnum_Debet, kolNum_kredit, kolstr_NoReference As Integer
kolstr_Tanggal = 1
kolstr_Deskripsi = 2
kolnum_Debet = 3
kolNum_kredit = 4
kolstr_NoReference = 7
kolStr_Remark = 10
Dim sel As Range

Dim Arr_Simpan() As Variant
Dim jumItem As Integer
jumItem = 0
For Each sel In daerahku.Rows
isiNoReferensi = sel.Resize(1, 1).Offset(0, kolstr_NoReference - 1).Value
' jika ada perubahan no reference

If m_NoReferensi <> isiNoReferensi Then
If m_NoReferensi <> "" Then
' jika no referensi sbelumnya tak kosong
Call sortArray_2D(Arr_Simpan, 1)
Call hilangkantambahan(Arr_Simpan, 1)

Call TambahanZZ(Arr_Simpan, 1)
Call SimpanKetujuan(Arr_Simpan, tujuannya)
End If
m_NoReferensi = sel.Resize(1, 1).Offset(0, kolstr_NoReference - 1).Value
jumItem = 0
ReDim Arr_simpam(1, 1)
End If
If isiNoReferensi <> "" Then

jumItem = jumItem + 1
ReDim Preserve Arr_Simpan(7, jumItem)
'1--> posting key
'2--> Amount
'3--> MM atau ZZ
'4--> Transaction Date
'5--> No Reference
'6--> Remark

'7--> Acc No , dari mana
If sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value > 0 Then
Arr_Simpan(2, jumItem) = sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value
Else
Arr_Simpan(2, jumItem) = sel.Resize(1, 1).Offset(0, kolNum_kredit - 1).Value

End If
If UCase(Trim(sel.Resize(1, 1).Offset(0, kolstr_Deskripsi - 1).Value)) = "TOTAL" Then
Arr_Simpan(3, jumItem) = "MM"
' untuk total sisi Bank debet ( 31 ) perusahaan Kredit ( 25 )

If sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value > 0 Then
Arr_Simpan(1, jumItem) = 25 & "_" & "0"
Else
Arr_Simpan(1, jumItem) = 31 & "_" & "0"
End If

isiTanggal = sel.Resize(1, 1).Offset(0, kolstr_Tanggal - 1).Value
isiNoReference = sel.Resize(1, 1).Offset(0, kolstr_NoReference - 1).Value

Else
' sisi Bank debet ( 25 ) perusahaan Kredit ( 31 )
Arr_Simpan(3, jumItem) = ""
If sel.Resize(1, 1).Offset(0, kolnum_Debet - 1).Value > 0 Then
Arr_Simpan(1, jumItem) = 31 & "_" & jumItem

Else
Arr_Simpan(1, jumItem) = 25 & "_" & jumItem
End If
isiTanggal = ""
isiNoReference = ""
End If
' tak perlukan lagi
Arr_Simpan(4, jumItem) = isiTanggal

Arr_Simpan(5, jumItem) = isiNoReference

Arr_Simpan(6, jumItem) = sel.Resize(1, 1).Offset(0, kolStr_Remark - 1).Value
' Arr_Simpan(7, jumItem) = "" ' diisi dari mana ?
Arr_Simpan(7, jumItem) = kdAccCustomer

End If
labloop:
Next
Call sortArray_2D(Arr_Simpan, 1)
Call hilangkantambahan(Arr_Simpan, 1)
Call TambahanZZ(Arr_Simpan, 1)
Call SimpanKetujuan(Arr_Simpan, tujuannya)
End Function
Sub sortArray_2D(MyArray, posisikey)

jumkol = UBound(MyArray, 1)
Dim kel1 As Variant
Dim kel2 As Variant
ReDim kel1((jumkol))
ReDim kel2((jumkol))
For lLoop = 1 To UBound(MyArray, 2)
For lLoop2 = lLoop To UBound(MyArray, 2)
If UCase(MyArray(posisikey, lLoop2)) < UCase(MyArray(posisikey, lLoop)) Then

For i = 1 To UBound(MyArray, 1)
kel1(i) = MyArray(i, lLoop)
kel2(i) = MyArray(i, lLoop2)
MyArray(i, lLoop) = kel2(i)
MyArray(i, lLoop2) = kel1(i)
Next End If Next lLoop2
Next lLoop
End Sub
Sub hilangkantambahan(MyArray, posisikey)

For j = 1 To UBound(MyArray, 2)
strnya = MyArray(posisikey, j)
strnya = StrReverse(strnya)
posisi = InStr(1, strnya, "_")
If posisi > 0 Then
strnya = Mid(strnya, posisi + 1)
End If
strnya = StrReverse(strnya)

MyArray(posisikey, j) = strnya
Next j
End SubSub TambahanZZ(MyArray, posisikey)

'1--> posting key
'2--> Amount
'3--> MM atau ZZ
'4--> Transaction Date
'5--> No Reference
'6--> Remark
'7--> Acc No , dari mana
' MM ZZ

' 25 25
' 50
' 31 31
' 40
jumItem = UBound(MyArray, 2)
For j = 1 To jumItem
If j = 1 And MyArray(3, j) = "MM" Then
mPostingKey = MyArray(posisikey, j)
mAmount = MyArray(2, j)

mdoc = "ZZ"
mTanggal = MyArray(4, j)
mReferenceNo = MyArray(5, j)
mRemark = MyArray(6, j)
mAccNo = MyArray(7, j)
End If
Next j
ReDim Preserve MyArray(7, jumItem + 1)
MyArray(posisikey, jumItem + 1) = mPostingKey

MyArray(2, jumItem + 1) = mAmount
MyArray(3, jumItem + 1) = mdoc
MyArray(4, jumItem + 1) = mTanggal
MyArray(5, jumItem + 1) = mReferenceNo
MyArray(6, jumItem + 1) = mRemark
MyArray(7, jumItem + 1) = kdAccCustomer

If mPostingKey = 25 Then
mPostingKey = 50
ElseIf mPostingKey = 31 Then
mPostingKey = 40
Else
mPostingKey = ""
End If
jumItem = jumItem + 1
ReDim Preserve MyArray(7, jumItem + 1)

MyArray(posisikey, jumItem + 1) = mPostingKey
MyArray(2, jumItem + 1) = mAmount
MyArray(3, jumItem + 1) = "" ' mdoc
' MyArray(4, jumItem + 1) = mTanggal

MyArray(4, jumItem + 1) = ""
' MyArray(5, jumItem + 1) = mReferenceNo

MyArray(5, jumItem + 1) = ""

MyArray(6, jumItem + 1) = mRemark
' MyArray(7, jumItem + 1) = mAccNo
MyArray(7, jumItem + 1) = kdAccLedger

End Sub
Sub SimpanKetujuan(MyArray, Tujuan As Range)
Dim pjumItem As Integer
'1--> posting key
'2--> Amount
'3--> Doc Type : MM atau ZZ
'4--> Transaction Date
'5--> No Reference

'6--> Remark
'7--> Acc No , dari mana
'====
' Tanggal Doc-Type ReferenceNo PostingKey AccNo Amount Remark
pjumItem = UBound(MyArray, 2)
For j = 1 To pjumItem
'tambahkan no urut transaksi

If MyArray(3, j) <> "" Then
urutTrans = urutTrans + 1
Tujuan.Offset(j - 1, 0).Value = urutTrans
End If

Tujuan.Offset(j - 1, 1).Value = MyArray(4, j)
Tujuan.Offset(j - 1, 2).Value = MyArray(3, j)
Tujuan.Offset(j - 1, 3).Value = MyArray(5, j)
Tujuan.Offset(j - 1, 4).Value = MyArray(1, j)
Tujuan.Offset(j - 1, 5).Value = MyArray(7, j)

Tujuan.Offset(j - 1, 6).Value = MyArray(2, j)
Tujuan.Offset(j - 1, 7).Value = MyArray(6, j)
Next j
Set Tujuan = Tujuan.Offset(pjumItem, 0)
End Sub

> To: belajar-excel@yahoogroups.com

> From: dbpermatasari@gmail.com
> Date: Fri, 2 Dec 2011 16:32:07 +0800

> Subject: Re: [belajar-excel] Masalah Lookup yang rumit
>

> Pak Sudarsono,
>
> Menurut saya hasilnya udah 95% memenuhi kebutuhan saya.
> (1) Yang kurang hanya sedikit, di kolom yang kosong maunya diisi no account
> yang tetap yaitu 6932942.mungkin boleh disebut di makro Acc No = 6932942.

> Bagitu juga GL 871814 adalah tetap dan tidak berubah, dan polanya tetap
> sama seperti posisi di table asli di bawah.
>
> (2) Di kolom pertama sebelum tanggal ada nomor urut. Polanya no 1 berada di

> baris yang sama dgn MM, no 2 di baris ZZ, no 3 MM semula, bagitulah
> seterusnya no 4 ZZ.
>
> (3) Tanggal hanya ditulis dua kali sahaja yaitu sebaris dgn MM dan sebaris
> dgn ZZ, yang lain dikosongkan sama seperti MM dan ZZ.

>
> 4) Selain untuk tujuan upload data ke sistem SAP, Table ini juga
> berfungsi sebagai filter kepada Table statement dari bank, sebab data dari
> bank bertambah setiap hari, tapi yang mau di lihat hanya data dari tanggal

> tertentu sahaja.. Mungkin supaya lebih user friendly, tanggalnya bisa
> diselect contohnya
>
> Tanggal dari 18 Nov 2011 hingga 23 Nov 2011 atau hanya satu tanggal sahaja
> e.g 24 Nov 2011, maka yang muncul hanyalah tanggal yang diperlukan sahaja.

>
> Terima kasih sekali lagi atas bantuan bapak.
>
> -Mansor.

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (11)

4a.

Re: ListBox Multi Selection

Posted by: "Onto Seno" ontoseno84@gmail.com   ontoseno84@ymail.com

Mon Dec 5, 2011 1:12 am (PST)

Maaf masih mau nambah sedikit
Jika Listbobx tidak di buat di USERFORM (tetapi dibuat langsung di SHEET)
maka Listbox (ActiveX control) tsb bisa diatur beberapa propertiesnya
melalui
kotak/jendela Propertiesnya tanpa harus melalui pemrograman VBA (makro)

contoh terlmpir

[image: activeX control box.PNG]

Poperties diisi dlm mode DesignTime, tidak memerlukan makhro

[image: listbox properties.PNG]

2011/12/5 Purnomo Sidi <pysa_2605@yahoo.com>
>
> Trims Pak/Mas Onto Seno. kebetulan saya ingat banget file tersebut
> berhubungan dengan Hide sheet. Sayangnya saya tidak tahu banyak tentang
> macro jadi *(bagi saya)* sangat sulit di terapkan di kasus saya. sekali
> lagi terima kasih atas bantuannya
>
> ------------------------------
> *From:* Onto Seno <ontoseno84@gmail.com>
> *Sent:* Monday, December 5, 2011 10:59 AM
> *
> *
> Bisa... dengan mempengaruhi NILAI *PROPERTI*NYA yg bernama *'MultiSelect'*
> Kalau anda pernah melihat fie contoh dari bu boss siti: *Sheet Manager
> xls *(maaf boss)
> http://www.box.com/shared/1u16ctdvlj / downloadable / unduhable? ..
> di situ di suatu userform dibuat Listbox yg itemsnya dapat dipilih dengan
> cara multi select
> smart dech pokoknya....
> 'o Seno
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (4)

5a.

Dynamic row

Posted by: ""andre"" qlick@inbox.com   andrepri@ymail.com

Mon Dec 5, 2011 1:25 am (PST)

Dear Exceler,

Apakah formula untuk dynamic row?, file kasus terlampir.

salam

- andre -

__________________________________________________________
FREE 3D MARINE AQUARIUM SCREENSAVER - Watch dolphins, sharks & orcas on your desktop!
Check it out at http://www.inbox.com/marineaquarium

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (3)

5b.

Re: Dynamic row

Posted by: "Kid Mr." mr.nmkid@gmail.com   nmkid.family@ymail.com

Mon Dec 5, 2011 1:34 am (PST)

Dear Andre,

1. Untuk rujukan range dinamis deret bilangan bulat positif :
>> cara 1 ::
ganti Row(1:20) dengan row(nama)-1
>> cara 2 ::
buat nama range (misal baris), dengan refers to : =row( index( nama
, 0 ) ) - 1
kemudian ganti row(1:20) dengan baris

2. Error trap di xl2007, manfaatkan IFError
=IFError( formula_kerja , "pengganti nilai error" )

Kid.

On Mon, Dec 5, 2011 at 16:06, "andre" <qlick@inbox.com> wrote:

> **
>
>
> Dear Exceler,
>
> Apakah formula untuk dynamic row?, file kasus terlampir.
>
> salam
>
> - andre -
>
> __________________________________________________________
> FREE 3D MARINE AQUARIUM SCREENSAVER - Watch dolphins, sharks & orcas on
> your desktop!
> Check it out at http://www.inbox.com/marineaquarium
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (3)

5c.

Bls: [belajar-excel] Dynamic row

Posted by: "ghozi alkatiri" ghozialkatiri@yahoo.co.id   ghozialkatiri

Mon Dec 5, 2011 4:00 am (PST)

kalau yang diinginkan sekedar row dinamis , saya menawarkan solusi formula dinamis dimana untuk seluruh baris yang ada cukup mengcopy dari baris di atasnya dan akan berubah secara dinamis dan fleksibel sesuai dengan perubahan referensinya

formula yang sebelumnya
=INDEX(NAMA,SMALL(IF((DIVISI=$F2)*(PT=$F$1),ROW($1:$20)),COLUMN($1:$1)))

dan setiap nama PT berubah referensi formula masih harus dirubah secara manual

maka saya buatkan formula pengubah nama PT secara otomatis dengan fomula

=INDEX(F$1:F1;TRUNC((ROW()-1)/4)*4+1)

maka secara keseluruhan formula dirubah menjadi

{=IFERROR(INDEX(NAMA;SMALL(IF((DIVISI=$F1)*(PT=INDEX(F$1:F1;TRUNC((ROW()-1)/4)*4+1));ROW($1:$26));COLUMN($1:$1)));"")}

formula ini adalah formula array yang di input sekaligus dalam beberapa kolom

untuk kasus ini formula awal ditulis di G1 kemudian sorot range G1:K1 (5 kolom) tekan enter sambil menahan tombol shift dan CTRL.

copy ke bawah  sampai tuntas tanpa hambatan karena sudah ada jebakan error (IFERROR) pada cell yang menghasilkan nilai saya akan menghasilkan blank cell.

wassalam

Ghozi Alkatiri

________________________________
Dari: ""andre"" <qlick@inbox.com>
Kepada: ""Belajar Excel"" <belajar-excel@yahoogroups.com>
Dikirim: Senin, 5 Desember 2011 16:06
Judul: [belajar-excel] Dynamic row


 
Dear Exceler,

Apakah formula untuk dynamic row?, file kasus terlampir.

salam

- andre -

__________________________________________________________
FREE 3D MARINE AQUARIUM SCREENSAVER - Watch dolphins, sharks & orcas on your desktop!
Check it out at http://www.inbox.com/marineaquarium

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (3)

6a.

Re: mengunci cell terisi di validation

Posted by: "Onto Seno" ontoseno84@gmail.com   ontoseno84@ymail.com

Mon Dec 5, 2011 1:33 am (PST)

Diinginkan membatasi pemasukan datanya dengan data validation ?
Lha kan sebelumnya di cell itu sudah ada data-validation-nya (=list)
Mengubah *validasi data* setiap sebuah cell habis diisi nilai > 0 tentu
tidak ada
otomatisasinya (kalau harus manual) kecuali boleh dengan makhro

Barngkali penguncian cell yg sudah diisi dengan data > 0 bisa dipakai cara
bb:

- sebelumnya; range yg akan diberlakukan seperti itu : di UNLOCK dulu
- kemudian dibuatkan makro yg otomatis meLOCK cell tsb dengan syarat
# jika ada cell (di daerah tertentu misal D7 : D65000) berubah nilainya >
0
maka cell tsb di LOCK
( sebelum dan sesudahnya urusi dulu Unproteksi/Proteksi sheetnya.)

==== modul level sheet =====
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count = 1 Then
If Target.Row > 6 Then
If Target.Column = 4 Then
If Target.Value > 0 Then
Me.Unprotect "koplo"
Application.EnableEvents = False
Target.Locked = True
Application.EnableEvents = True
Me.Protect "koplo"
End If
End If
End If
End If
End Sub

o' Seno
lampiran, jika diperlukan, akan dikirim hanya atas permintaan.

2011/12/5 Tony Bexcel <tonybexcel@yahoo.co.id>
>
> Dear Pakar yang Budiman,
> Selamat pagi temanz..Mohon bantuan nya dooong..saya ingin tau apakah ada
cara untuk mengunci cell dari list validation bila sudah terisi tidak bisa
di ubah lagi?
> Berikut lampiran contoh dari masalah saya.
> Terimakasih banyak atas segala bantuan dan waktunya untuk temanz semua..
> Salam,
> Tony

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (2)

7a.

Replace Data Perbaris

Posted by: "muja" mail4muja@yahoo.co.id   mail4muja

Mon Dec 5, 2011 1:40 am (PST)

Salam buat XL Master,

Mohon bantuannya memecahkan masalah code replace data nih (file terlampir) sbb :

- Dalam userform terdapat 1 bh kontrol Listbox, 3 bh Textbox dan 1 bh Command.
- Listbox tsb memuat multi kolom (disini menggunakan 3 Kolom), dan jika di klik list yang ada maka data akan tampil di textbox
- Nah bagaimana cara menganti/mereplace data yang melalui textbox tersebut dengan Command.???
- Code yang sudah di buat terlampir hanya mampu mereplace 1 kolom saja.

Demikian disampaikan, atas bantuannya diucapkan terima kasih.

Mas Muja
========

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (2)

7b.

Re: Replace Data Perbaris

Posted by: "Onto Seno" ontoseno84@gmail.com   ontoseno84@ymail.com

Mon Dec 5, 2011 4:02 am (PST)

"Lha wong" range sedang dijadikan rowSource kok mau di-ubek-ubek.. seh.."
Barangkali itulah yg menyusahkan pengubahannya

Kita cari cara lain "mengisikan data value yg ada di range A2:Cn / sheet 1
bukan dengan memasukkan Range nya ke property *RowSource* tetapi valuesnya
kita ambil satu persatu untuk mengisi Lisbox dengan metoda *AddItem*

*=== module userform ====*
Dim Tabel As Range, R As Long, i As Long

Private Sub UserForm_Initialize()
Set Tabel = Sheets("Sheet1").Range("A1").CurrentRegion.Offset(1, 0)
Application.EnableEvents = False
With ListBox1
.Clear
For i = 1 To Tabel.Rows.Count - 1
.AddItem
.List(.ListCount - 1, 0) = Tabel(i, 1)
.List(.ListCount - 1, 1) = Tabel(i, 2)
.List(.ListCount - 1, 2) = Tabel(i, 3)
Next i
.BoundColumn = 1
.ColumnCount = 3
.ColumnHeads = True
.TextColumn = True
.ListStyle = fmListStyleOption
.ListIndex = 0
End With
Application.EnableEvents = True
End Sub

Private Sub ListBox1_Change()
Application.EnableEvents = False
With ListBox1
If .ListIndex > -1 Then
R = .ListIndex
TextBox4 = .List(R, 0)
TextBox5 = .List(R, 1)
TextBox6 = .List(R, 2)
End If
Tabel(.ListIndex + 1, 1).Resize(1, Tabel.Columns.Count).Select
End With
Application.EnableEvents = True
End Sub

Private Sub cmdReplace_Click()
Application.EnableEvents = False
Tabel(R + 1, 1) = TextBox4
Tabel(R + 1, 2) = TextBox5
Tabel(R + 1, 3) = TextBox6
With Me.ListBox1
'--- bagian ini sebetulnya bisa diganti: hanya mengganti
' 1 item (3 data sebaris) saja
.Clear
For i = 1 To Tabel.Rows.Count - 1
.AddItem
.List(.ListCount - 1, 0) = Tabel(i, 1)
.List(.ListCount - 1, 1) = Tabel(i, 2)
.List(.ListCount - 1, 2) = Tabel(i, 3)
Next i
'--------------
End With
Application.EnableEvents = True
End Sub

2011/12/5 muja <mail4muja@yahoo.co.id>
> Salam buat XL Master,
> Mohon bantuannya memecahkan masalah code replace data nih (file
terlampir) sbb :
> - Dalam userform terdapat 1 bh kontrol Listbox, 3 bh Textbox dan 1 bh
Command.
> - Listbox tsb memuat multi kolom (disini menggunakan 3 Kolom), dan jika
di klik list yang ada maka data akan tampil di textbox
> - Nah bagaimana cara menganti/mereplace data yang melalui textbox
tersebut dengan Command.???
> - Code yang sudah di buat terlampir hanya mampu mereplace 1 kolom saja.
> Demikian disampaikan, atas bantuannya diucapkan terima kasih.
> Mas Muja
> ========

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (2)

8a.

Apa Perbedaan Format Save As Binary dg Save As lainnya

Posted by: "PT. ADHI KARYA (PERSERO) Tbk" adhi_tax_dk3@yahoo.com   adhi_tax_dk3

Mon Dec 5, 2011 1:54 am (PST)

Para pakar XL, mohon ilmunya diturunkan ke saya dong, perbedaan & plus-minusnya penyimpanan file dengan format Binary dibanding kalo dengan menggunakan format penyimpanan macro atau lainnya...
 
Tks

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (2)

8b.

Re: Apa Perbedaan Format Save As Binary dg Save As lainnya

Posted by: "Onto Seno" ontoseno84@gmail.com   ontoseno84@ymail.com

Mon Dec 5, 2011 4:37 am (PST)

sambil menunggu penjelasan fara fakar...
sebagian besar ilmunya sudah ada di dalam excel help, atau banyak juga di
pajang di internyet, misal di sini

http://en.wikipedia.org/wiki/Microsoft_Excel

2011/12/5 PT. ADHI KARYA (PERSERO) Tbk <adhi_tax_dk3@yahoo.com>

> **
> Para pakar XL, mohon ilmunya diturunkan ke saya dong, perbedaan &
> plus-minusnya penyimpanan file dengan format Binary dibanding kalo dengan
> menggunakan format penyimpanan macro atau lainnya...
> Tks
>
>
>

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (2)

9a.

Fungsi Drop down list plus vlookup

Posted by: "harry budiman" harbudiman@gmail.com   harbudiman

Mon Dec 5, 2011 3:42 am (PST)

Salam para pakar

Saya ingin menanyakan beberapa rumus paduan dropdown list dan vlook up
dari data yang saya lampirkan,
terima kasih atas bantuannya

salam
harry

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (5)

9b.

Re: Fungsi Drop down list plus vlookup

Posted by: "Onto Seno" ontoseno84@gmail.com   ontoseno84@ymail.com

Mon Dec 5, 2011 4:22 am (PST)

Insert kolom baru ( misal menjadi kolom I)
Rumus di *I4:I20* (atau lebih ke bawah lagi, sebanyak data yg diperkirakan
tersaring
/ memenuni kriteria "Nama Satelite"
array formula
*=SMALL(IF(F4:F30=H4,ROW(1:27)),ROW(1:27))*

Rumus di J4 / formula biasa
*=IF(ISNUMBER($I4),OFFSET(C$3,$I4,0),"")*

Rumus tsb dicopy ke arah bawah dan kanan seluas yg diperlukan
Semoga seperti itu yg dimaksudkan oleh pak harry budiman
(hasil lebih dari 1)

2011/12/5 harry budiman <harbudiman@gmail.com>
>
> Salam para pakar
> Saya ingin menanyakan beberapa rumus paduan dropdown list dan vlook up
> dari data yang saya lampirkan,
> terima kasih atas bantuannya
>
> salam
> harry

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (5)

9c.

Re: Fungsi Drop down list plus vlookup

Posted by: "harbudiman@gmail.com" harbudiman@gmail.com   harbudiman

Mon Dec 5, 2011 4:25 am (PST)

Mgkn sebagai tambahan, saya ingin mengetahui ketika saya pilih satelit 1 maka akan muncul unit apa saja yg ada di satelit 1 berikut no rangka dan warna unit tersebut

Sent from my BlackBerry� smartphone from Sinyal Bagus XL, Nyambung Teruuusss...!

-----Original Message-----
From: harry budiman <harbudiman@gmail.com>
Date: Mon, 5 Dec 2011 18:42:19
To: belajar-excel<belajar-excel@yahoogroups.com>
Subject: Fungsi Drop down list plus vlookup

Salam para pakar

Saya ingin menanyakan beberapa rumus paduan dropdown list dan vlook up
dari data yang saya lampirkan,
terima kasih atas bantuannya

salam
harry

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (5)

9d.

Bls: [belajar-excel] Re: Fungsi Drop down list plus vlookup

Posted by: "ghozi alkatiri" ghozialkatiri@yahoo.co.id   ghozialkatiri

Mon Dec 5, 2011 5:36 am (PST)

untuk konsistensi referensi formula ganti judul kepala pada tabel
summary sama persis  dengan judul kepala pada tabel sumber data dengan
formula misalkan judul kepala Type yang asalnya dari C3 pada judul
kepala summary di I3 tulis =I3 sehinngga sama persis dengan sumber asal
demikian juga untuk judul kepala yang lain.

selanjutnya tulis formula array di  I4

{=IFERROR(INDEX($C$4:$F$30;SMALL(IF($F$4:$F$30=$H$4;ROW($F$4:$F$30));ROW(1:1))-3;MATCH(I$3;$C$3:$F$3;0));"")}

copy ke kanan dan ke bawah sampai tuntas

wassalam

Ghozi Alkatiri

----- Pesan Asli -----
Dari: "harbudiman@gmail.com" <harbudiman@gmail.com>
Kepada: belajar-excel <belajar-excel@yahoogroups.com>
Cc:
Dikirim: Senin, 5 Desember 2011 19:25
Judul: [belajar-excel] Re: Fungsi Drop down list plus vlookup

Mgkn sebagai tambahan, saya ingin mengetahui ketika saya pilih satelit 1 maka akan muncul unit apa saja yg ada di satelit 1 berikut no rangka dan warna unit tersebut

Sent from my BlackBerry® smartphone from Sinyal Bagus XL, Nyambung Teruuusss...!

-----Original Message-----
From: harry budiman <harbudiman@gmail.com>
Date: Mon, 5 Dec 2011 18:42:19
To: belajar-excel<belajar-excel@yahoogroups.com>
Subject: Fungsi Drop down list plus vlookup

Salam para pakar

Saya ingin menanyakan beberapa rumus paduan dropdown list dan vlook up
dari data yang saya lampirkan,
terima kasih atas bantuannya

salam
harry

------------------------------------

----------------------------------------------------------
bergabung ke milis (subscribe), kirim mail kosong ke:
belajar-excel-subscribe@yahoogroups.com

posting ke milis, kirimkan ke:
belajar-excel@yahoogroups.com

berkunjung ke web milis
http://tech.groups.yahoo.com/group/belajar-excel/messages

melihat file archive / mendownload lampiran
http://www.mail-archive.com/belajar-excel@yahoogroups.com/
atau (sejak 25-Apr-2011) bisa juga di :
http://milis-belajar-excel.1048464.n5.nabble.com/

menghubungi moderators & owners: belajar-excel-owner@yahoogroups.com

keluar dari membership milis (UnSubscribe):
kirim mail kosong ke  belajar-excel-unsubscribe@yahoogroups.com
----------------------------------------------------------Yahoo! Groups Links

    http://docs.yahoo.com/info/terms/

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (5)

9e.

Re: Bls: [belajar-excel] Re: Fungsi Drop down list plus vlookup

Posted by: "harbudiman@gmail.com" harbudiman@gmail.com   harbudiman

Mon Dec 5, 2011 6:12 am (PST)

It work..makasih atas bantuannya mas Seno dan Pak Ghozi...syukron katsiron..

Salam
Sent from my BlackBerry� smartphone from Sinyal Bagus XL, Nyambung Teruuusss...!

-----Original Message-----
From: ghozi alkatiri <ghozialkatiri@yahoo.co.id>
Sender: belajar-excel@yahoogroups.com
Date: Mon, 5 Dec 2011 21:36:14
To: belajar-excel@yahoogroups.com<belajar-excel@yahoogroups.com>
Reply-To: belajar-excel@yahoogroups.com
Subject: Bls: [belajar-excel] Re: Fungsi Drop down list plus vlookup

untuk konsistensi referensi formula ganti judul kepala pada tabel
summary sama persis� dengan judul kepala pada tabel sumber data dengan
formula misalkan judul kepala Type yang asalnya dari C3 pada judul
kepala summary di I3 tulis =I3 sehinngga sama persis dengan sumber asal
demikian juga untuk judul kepala yang lain.

selanjutnya tulis formula array di� I4

{=IFERROR(INDEX($C$4:$F$30;SMALL(IF($F$4:$F$30=$H$4;ROW($F$4:$F$30));ROW(1:1))-3;MATCH(I$3;$C$3:$F$3;0));"")}

copy ke kanan dan ke bawah sampai tuntas

wassalam

Ghozi Alkatiri



----- Pesan Asli -----
Dari: "harbudiman@gmail.com" <harbudiman@gmail.com>
Kepada: belajar-excel <belajar-excel@yahoogroups.com>
Cc:
Dikirim: Senin, 5 Desember 2011 19:25
Judul: [belajar-excel] Re: Fungsi Drop down list plus vlookup

Mgkn sebagai tambahan, saya ingin mengetahui ketika saya pilih satelit 1 maka akan muncul unit apa saja yg ada di satelit 1 berikut no rangka dan warna unit tersebut

Sent from my BlackBerry� smartphone from Sinyal Bagus XL, Nyambung Teruuusss...!

-----Original Message-----
From: harry budiman <harbudiman@gmail.com>
Date: Mon, 5 Dec 2011 18:42:19
To: belajar-excel<belajar-excel@yahoogroups.com>
Subject: Fungsi Drop down list plus vlookup

Salam para pakar

Saya ingin menanyakan beberapa rumus paduan dropdown list dan vlook up
dari data yang saya lampirkan,
terima kasih atas bantuannya

salam
harry



------------------------------------

----------------------------------------------------------
bergabung ke milis (subscribe), kirim mail kosong ke:
belajar-excel-subscribe@yahoogroups.com

posting ke milis, kirimkan ke:
belajar-excel@yahoogroups.com

berkunjung ke web milis
http://tech.groups.yahoo.com/group/belajar-excel/messages

melihat file archive / mendownload lampiran
http://www.mail-archive.com/belajar-excel@yahoogroups.com/
atau (sejak 25-Apr-2011) bisa juga di :
http://milis-belajar-excel.1048464.n5.nabble.com/

menghubungi moderators & owners: belajar-excel-owner@yahoogroups.com

keluar dari membership milis (UnSubscribe):
kirim mail kosong ke� belajar-excel-unsubscribe@yahoogroups.com
----------------------------------------------------------Yahoo! Groups Links



� � http://docs.yahoo.com/info/terms/

Back to top

Reply to sender | Reply to group | Reply via web post
Messages in this topic (5)

Recent Activity

•  22
  New Members

Visit Your Group

Yahoo! Groups

Small Business Group

Own a business?

Connect with others.

Yahoo! Finance

It's Now Personal

Guides, news,

advice & more.

Yahoo! Groups

Parenting Zone

Community resources

for parents

Need to Reply?

Click one of the "Reply" links to respond to a specific message in the Daily Digest.

Create New Topic | Visit Your Group on the Web

Messages

---------------------------------------------------------------------
bergabung ke milis (subscribe), kirim mail kosong ke:
belajar-excel-subscribe@yahoogroups.com

posting ke milis, kirimkan ke:
belajar-excel@yahoogroups.com

berkunjung ke web milis
http://tech.groups.yahoo.com/group/belajar-excel/messages

melihat file archive / mendownload lampiran
http://www.mail-archive.com/belajar-excel@yahoogroups.com/
atau (sejak 25-Apr-2011) bisa juga di :
http://milis-belajar-excel.1048464.n5.nabble.com/

menghubungi moderators & owners: belajar-excel-owner@yahoogroups.com

keluar dari membership milis (UnSubscribe):
kirim mail kosong ke  belajar-excel-unsubscribe@yahoogroups.com
---------------------------------------------------------------------

MARKETPLACE

Stay on top of your group activity without leaving the page you're on - Get the Yahoo! Toolbar now.

Change settings via the Web (Yahoo! ID required)
Change settings via email: Switch delivery to Individual | Switch format to Traditional
Visit Your Group | Yahoo! Groups Terms of Use | Unsubscribe