Re: ]] XL-mania [[ Merge kolom bersyarat

kepada: ysh. Pak Eko Wahyudi (thread-maker) dimohon jangan merasa terganggu

karena posting ini tidak saya tujukan kepada anda, melainkan untuk keperluan 

pembelajaran makro/vba excel bagi members yg sedang mulai ber-makro-ria

Coding yg sudah ada itu masih dapat di ringkas sbb

Sub MergeCellBersyarat()

   ' coded by: siti Vi / Oct 26, 2011

   ' Merge cells yg valuenya sama

   ' sebelumnya, Range haru sudah diSelect

   ' short-cut = Ctrl+Shift+M

   '--------------------------------

   Dim X As Range, c As Integer

   Set X = Selection(1, 1)

   Application.DisplayAlerts = False

   

   Do

      c = WorksheetFunction.CountIf(Selection, X)

      X.Resize(1, c).Merge

      Set X = X(1, c + 1)

   Loop Until Len(X) = 0

   

   Application.DisplayAlerts = True

End Sub

Di sini perbedaanya adalah

* Variable 'Blok' yg akan mewakili SelectedRange tidak dipakai lagi, karena

object range tsb tidak akan terlalu banyak dirujuk dan ekspresi-nya pun 

sudah cukup pendek (that is ="Selection")

* syarat Penghentian Loop di letakkan di bagian Loop UNTIL (SYARAT)

bukan lagi di tengah loop seperti sebelumnya

* pemfilteran dengan IF tidak diberlakukan lagi, karena kita berasumsi bahwa

Range 'Selection' (berupa sebaris cells) yg di-select untuk diproses, semua 

berisi data; tidak ada cell yang kosong.

* variable integer c di tiap akhir step, tidak perlu di reset ( c= 0), karena

di awal step sudah pasti diperbarui dengan nilai ex Countif(Selection, X)

Sedangkan prinsip-kerja-nya tetap sama, yaitu :

( berupa rangkaian actions /tindakan tiap step dlm Loop )

0. Di awal proses, sebelum Loop, Cell pertama (object range) diingat dlm variable X

1. di dlm Selecttion dicari: ada berapa cell yg mempunyai nilai (isi) sama ?

   Cacah data yg samadengan isi X diingat dlm variable integer C

2. Range X diperluas (resize) menjadi selebar C (kolom x 1 row), 

   sembari langsung di MERGE!

3. Variable object X di set baru dengan Cell yg letaknya ada di Letak Semula

   tapi "pakai acara" digeser ke kanan sebannyak C + 1 kolom.

   (=yaitu cell pertama SETELEH sekelompok cells sebaris yg baru saja di Merge)

3 (tiga) tindakan ini diulang-ulang (Do - Loop) Until (sampai) terdeteksi Range X

= berupa cell kosong...

Hal kecil yg sudah lumrah, tetapi semoga menjadi penyemangat mereka yg baru

mencebur ke sungai VBA yg jernih dan segar menyenangkan..

cmiiw

~siti

On Thu, Oct 27, 2011 at 12:50 AM, STDEV(i) <setiyowati.devi@gmail.com> wrote:

Listing Code nya:

Sub MergeCellBersyuarat()

   ' coded by: siti Vi / Oct 26, 2011

   ' meMerge cell yg valuenya sama

   ' kiboar short-cut = Ctrl+Shift+M

   '--------------------------------

   Dim Blok As Range, X As Range, c As Integer

   Set Blok = Selection: Set X = Selection(1, 1)

   Application.DisplayAlerts = False

   Do

      c = WorksheetFunction.CountIf(Blok, X)

      If c > 0 Then

         X.Resize(1, c).Merge

         Set X = X(1, c + 1): c = 0

         If Len(X.Value) = 0 Then Exit Do

      End If

   Loop

   Application.DisplayAlerts = True

End Sub

Menjalannya:

Blok-lah range yg akan diproses (misal: range E5:BD5)

lalu tekan tombol Ctrl + Shift + M

~siti