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.
