Terima kasih Pak De atas codesnya yang begitu singkat dan jelas. Ada 2 kombinasi yang "sangat indah": - On Error Resume Next ..... dan - cKode.Add Trim(Rng), CStr(Rng)
Ada yang ingin saya tanyakan mengenai Dim cKode As New Collection. Apakah New Collection merupakan Array untuk numbers ? Salam, HK ________________________________ From: De Premor <[email protected]> To: [email protected] Sent: Wednesday, 2 October 2013, 22:37 Subject: Re: [belajar-excel] Langsung masuk ke sheet yang diinginkan Ikutan urun rembug :D Sub Masukin() Dim SrcData As Range, Rng As Range Dim cKode As New Collection Dim LRow As Long Application.ScreenUpdating = False Set SrcData = Sheet1.Range("D3", Sheet1.Range("D3").End(xlDown)) On Error Resume Next For Each Rng In SrcData cKode.Add Trim(Rng), CStr(Rng) Next For LRow = 1 To cKode.Count Set Rng = SrcData.CurrentRegion.Offset(1, 1).Resize(SrcData.Rows.Count - 1, 2) SrcData.CurrentRegion.AutoFilter Field:=4, Criteria1:=cKode.Item(LRow) Rng.SpecialCells(xlCellTypeVisible).Copy Sheets(cKode.Item(LRow)).Range("B3") SrcData.CurrentRegion.AutoFilter Next Application.ScreenUpdating = True End Sub On 02-10-2013 17:27, hendrik karnadi wrote: >Jawaban terlampir menggunakan macro warisan si Mbah dengan modifikasi sana >sini. >Angka2 (kelompok) 1,2,3,4,5 yang ada pada data maupun nama sheet terpaksa saya >ganti menjadi jenis biaya yang ada pada Range("A1") masing2 sheet. > > >Hal tersebut saya lakukan karena fungsi Instr yang dipakai untuk membuat Array >Unique Values membutuhkan data string bukan angka > > >Macronya adalah spt ini: >Sub splittable() > ' siti Vi (updated by Hendrik) > ' declarations of variables > Dim RefTbl As Range > Dim sNames As String, ArrNames > Dim r As Long, n As Long, i As Long > > ' turn off dialoque > ' freezing the screen > Application.DisplayAlerts = False > Application.ScreenUpdating = False > > ' setting data reference > Set RefTbl = Sheets("Sheet1").Range("B3", Range("B3").End(xlDown)) > Set RefTbl = RefTbl.Resize(RefTbl.Rows.Count - 1, 3) > > ' creating unique list of Names > For r = 1 To RefTbl.Rows.Count > If InStr(1, sNames, RefTbl(r, 3) & "|") = 0 Then > sNames = sNames & RefTbl(r, 3) & "|" > End If > Next > ArrNames = Split(sNames, "|") > > ' split the data > For i = LBound(ArrNames) To UBound(ArrNames) - 1 > Sheets(ArrNames(i)).Select > n = 2 > For r = 1 To RefTbl.Rows.Count > If RefTbl(r, 3) = ArrNames(i) Then > n = n + 1 > RefTbl(r, 1).Resize(1, 2).Copy > Cells(n, 2).PasteSpecial xlPasteValuesAndNumberFormats > End If > Next r > Application.CutCopyMode = False > Next i > > ' turn on dialoque > ' unfreezing the screen > Application.DisplayAlerts = True > Application.ScreenUpdating = True >End Sub > > >Pertanyaannya; >Bagaimanakah penulisan macro untuk mendapatkan Array Unique Values yang berupa >angka ? > > >Terima kasih. > > >Salam, >HK > > > > > > > >________________________________ > From: Topenk Baday <[email protected]> >To: [email protected] >Sent: Wednesday, 2 October 2013, 10:10 >Subject: [belajar-excel] Langsung masuk ke sheet yang diinginkan [1 Attachment] > > > > >Dimohon bantuannya, > >Kami lampirkan contoh permasalahan, >Mohon "rumus excel atau makro"-nya supaya data yang diinginkan dapat masuk >langsung sesuai dengan kode yang diinginkan. >Terima kasih sebelumnya. > > > > > > > >
