Solusi 'Pencet_Tombol' / hasil berupa tabel berisi konstanta
(diharapkan, jika tabel cukup besar, konstanta tidak akan membebani
kinerja worksheets)
'--------------
Sub SisipTanggalTakBerTransaksi(TBL As Range)' Hapsari // 01 sep 2011
' courtesy of mbak siti
'----------------------
Dim HSL As Range, TglAkir As Integer
Dim i As Long, n As Long, r As Long
Dim tRow As Long, tCol As Integer, c As Integer
Dim TGL As Date, StrTgl As String, ArRec()
'-- tentukan letak dimensi Tabel yg akan diproses
On Error GoTo endd
Set TBL = Application.InputBox("Tentukan Tabel Sumber yg ada.", _
"Input Range Sumber", TBL.Address, , , , , 8)
tRow = TBL.Rows.Count: tCol = TBL.Columns.Count
'-- meyalin Header
TBL.Resize(2, tCol).Copy TBL(tRow + 7, 1)
Application.CutCopyMode = False
'--tentukan Tabel tanpa header
Set TBL = TBL.Offset(2, 0).Resize(tRow - 2, tCol)
Set HSL = TBL.Offset(tRow + 6, 0)
' tentukan Tgl patokan, tgl-akhir,
TGL = TBL(1, 2).Value: StrTgl = "|"
TglAkir = Day(DateSerial(Year(TGL), Month(TGL) + 1, 0))
' menon-aktifkan Calc otomatik & screenupdating
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' tabel sumber di catat dlm array 6 X n
tRow = TBL.Rows.Count
For n = 1 To tRow
StrTgl = StrTgl & Day(TBL(n, 2)) & "|"
ReDim Preserve ArRec(1 To tCol, 1 To n)
ArRec(2, n) = TBL(n, 2): ArRec(3, n) = TBL(n, 3)
ArRec(4, n) = TBL(n, 4): ArRec(5, n) = TBL(n, 5)
ArRec(6, n) = "=R[-1]C+RC[-2]-RC[-1]"
Next n
' tgl lain masih (bulan yg sama), ditambahkan pada array
n = UBound(ArRec, 2)
For i = 1 To TglAkir
If InStr(1, StrTgl, "|" & i & "|", 1) = 0 Then
n = n + 1
ReDim Preserve ArRec(1 To tCol, 1 To n)
ArRec(2, n) = DateSerial(Year(TGL), Month(TGL), i)
ArRec(3, n) = "Tidak ada transaksi"
' ArRec(4, n) = 0: ' ArRec(5, n) = 0
ArRec(6, n) = "=R[-1]C+RC[-2]-RC[-1]"
End If
Next i
' Array hasil gabungan ditulis di range/tabel Hasil
For r = 1 To UBound(ArRec, 2)
For c = 1 To UBound(ArRec, 1)
HSL(r, c) = ArRec(c, r)
Next c
Next r
' perbaiki pengenalan letak & dimensi Tabel Hasil
Set HSL = HSL.CurrentRegion.Offset(2, 1)
Set HSL = HSL.Resize(UBound(ArRec, 2), UBound(ArRec, 1))
' Range Hasil di-SORT; kunci-sorting =kolom Tgl, urutan =menaik
SortTbl HSL
' tabel diberi nomor Urut (Records Index), di kolom 1
For i = 1 To UBound(ArRec, 2)
HSL(i, 0) = i
Next i
endd:
' reset Calc & ScreenUpdating
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
'------
mudah-mudhan ada manfaatnya
2011/8/30 Iwan Kesuma <iwan.kesuma@yahoo.com>
>
> Dear Para Master XL,
> Mohon bantuannya. Bagaimanakah caranya menyisipkan baris diantara 2 tanggal
> dan otomatis mengisi baris yg kosong dengan tanggal selanjutnya?
> Contoh terlampir.
>
> Regards,
> Iwan
__._,_.___
+-:: XL-mania ::::::::::::::::::::----------------------------------+
| selamat idul fitri, mohon maaf lahir dan batin... |
| www.linkedin.com/company/xl-mania |
| ayo pesan buku "mengapa boss benci chart anda" :D :D :D |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message, melecehkan, tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan winzip jika perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/ |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau... |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html |
+-------------------------------------------------------------------+
| Message lama ada di : |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id] |
| http://www.mail-archive.com/xl-mania@yahoogroups.com |
+-------------------------------------------------------------------+
| selamat idul fitri, mohon maaf lahir dan batin... |
| www.linkedin.com/company/xl-mania |
| ayo pesan buku "mengapa boss benci chart anda" :D :D :D |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message, melecehkan, tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan winzip jika perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/ |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau... |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html |
+-------------------------------------------------------------------+
| Message lama ada di : |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id] |
| http://www.mail-archive.com/xl-mania@yahoogroups.com |
+-------------------------------------------------------------------+
MARKETPLACE
.
__,_._,___
Nenhum comentário:
Postar um comentário