Sore Pak Ivan Coba seperti ini.
Sub ISI() Dim rowData As Integer Dim rowHasil As Integer Dim rowPaste As Integer 'Jarak setiap nota 25 row. 'row dihapus samape 35000 Rows("4:35000").Delete Shift:=xlUp ' titik awal pengambilan data rowData = 22 rowHasil = 2 rowPaste = 1 Range("A1:I3").Copy With Sheets("CETAK NOTA") Do Until .Cells(rowData, 7).Value = "" Range("A1:I3").Copy Cells(rowPaste, 1) 'kode toko Cells(rowHasil, 1).Value = .Cells(rowData - 21, 4).Value 'nama toko Cells(rowHasil, 2).Value = .Cells(rowData - 20, 7).Value & " " & .Cells(rowData - 19, 7).Value 'tanggal Cells(rowHasil, 3).Value = .Cells(rowData - 21, 7).Value 'tempo Cells(rowHasil, 4).Value = .Cells(rowData - 20, 3).Value 'jumlah Cells(rowHasil, 5).Value = .Cells(rowData, 7).Value 'disc rowData = rowData + 25 rowHasil = rowHasil + 4 rowPaste = rowPaste + 4 Loop End With End Sub Salam Suyono From: belajar-excel@yahoogroups.com [mailto:belajar-excel@yahoogroups.com] Sent: Thursday, October 08, 2015 10:52 PM To: belajar-excel@yahoogroups.com Subject: Bls: [belajar-excel] tolong dibantu perbaiki rumus makro vbanya... [1 Attachment] pak yono.. ada yg mau saya tanyakan lagi... rumus sub isi () pada modul 1 apa bisa disederhanakan lagi? saya ingin dengan menekan tombol isi maka hasilnya seperti pada sheet hasil.. file saya lampirkan... terima kasih pak.. Pada Rabu, 7 Oktober 2015 12:17, "Ivansl layona...@yahoo.co.id [belajar-excel]" <belajar-excel@yahoogroups.com> menulis: Waow.. Sempurna sekali rumusnya pak... Sesuai yg saya harapkan... Thx banget pak.. Sent from my PC On 7 Okt 2015, at 08.21, SUYONO reza.suy...@lge.com<mailto:reza.suy...@lge.com> [belajar-excel] <belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com>> wrote: Hehe.., coba seperti ini. Sub Rectangle7_Click() Dim lastRow As Long, i As Long, j As Long Dim idxrow As Integer Dim jml As Integer Dim item As String Dim getVal As Integer Dim satuan As String Range("I2:P473").ClearContents lastRow = 597 For i = 1 To lastRow item = Sheets("CETAK NOTA").Cells(i, 2).Value satuan = Sheets("CETAK NOTA").Cells(i, 4).Value If idxItem(item) > 1 Then getVal = Sheets("CETAK NOTA").Cells(i, 3).Value idxrow = idxItem(item) jml = Application.WorksheetFunction.CountA(Range(Cells(idxrow, 9), Cells(idxrow, 16))) jml = jml + 9 Sheets("REKAP FULL").Cells(idxrow, jml).Value = getVal Call Warna_Satuan(satuan, Sheets("REKAP FULL").Cells(idxrow, jml)) End If Next i End Sub Sub Warna_Satuan(satuan As String, rng As Range) With rng.Font Select Case satuan Case "pcs" .Color = -16776961 .TintAndShade = 0 Case "DOS" .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 ‘jika ada satuan lain bisa ditambahkan disini. End Select End With End Sub Public Function idxItem(item As String) As Integer On Error GoTo Err idxItem = Application.WorksheetFunction.Match(item, Sheets("REKAP FULL").Columns("C:C"), 0) Exit Function Err: idxItem = 0 End Function From: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> [mailto:belajar-excel@yahoogroups.com] Sent: Tuesday, October 06, 2015 9:55 PM To: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> Subject: Bls: [belajar-excel] tolong dibantu perbaiki rumus makro vbanya... [1 Attachment] pak ada yg mau saya tanyakan lagi nih... detailnya saya tulis difilenya... mohon bantuannya lagi... thx.. Pada Selasa, 6 Oktober 2015 19:08, "Ivan Sebastian layona...@yahoo.co.id<mailto:layona...@yahoo.co.id> [belajar-excel]" <belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com>> menulis: ups ternyata saya yg salah pak suyono... terima kasih bantuannya... cocok sesuai yg saya harapkan... rumus yg ini lupa saya copy...pantes aja hasilnya error... hahaha.. makasih pak.. top rumusnya.. Public Function idxItem(item As String) As Integer On Error GoTo Err idxItem = Application.WorksheetFunction.Match(item, Sheets("REKAP FULL").Columns("C:C"), 0) Exit Function Err: idxItem = 0 End Function Pada Selasa, 6 Oktober 2015 18:45, Ivan Sebastian <layona...@yahoo.co.id<mailto:layona...@yahoo.co.id>> menulis: sudah saya coba hasilnya... sub or function not defined... kayaknya ada yg salah nih.. Pada Selasa, 6 Oktober 2015 18:28, "SUYONO reza.suy...@lge.com<mailto:reza.suy...@lge.com> [belajar-excel]" <belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com>> menulis: Coba diganti seperti ini pak, semoga sesuai keinginan. Sub Rectangle7_Click() Dim lastRow As Long, i As Long, j As Long Dim idxrow As Integer Dim jml As Integer Dim item As String Dim getVal As Integer Range("I2:P473").ClearContents lastRow = 597 For i = 1 To lastRow item = Sheets("CETAK NOTA").Cells(i, 2).Value If idxItem(item) > 1 Then getVal = Sheets("CETAK NOTA").Cells(i, 3).Value idxrow = idxItem(item) jml = Application.WorksheetFunction.CountA(Range(Cells(idxrow, 9), Cells(idxrow, 16))) jml = jml + 9 Sheets("REKAP FULL").Cells(idxrow, jml).Value = getVal End If Next i End Sub ‘====================================== ‘fungsi untuk mencari indek item. ‘====================================== Public Function idxItem(item As String) As Integer On Error GoTo Err idxItem = Application.WorksheetFunction.Match(item, Sheets("REKAP FULL").Columns("C:C"), 0) Exit Function Err: idxItem = 0 End Function From: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> [mailto:belajar-excel@yahoogroups.com] Sent: Tuesday, October 06, 2015 1:35 PM To: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> Subject: Bls: [belajar-excel] tolong dibantu perbaiki rumus makro vbanya... [1 Attachment] terima kasih atas bantuannya pak suyono... kalo saya coba bikin ke bentuk dengan model lain lg... bisa bantu perbaiki rumusnya... kurang lebih hampir sama.. cuman jumlah item lebih banyak... thx.. data saya lampirkan... Pada Selasa, 6 Oktober 2015 7:34, "SUYONO reza.suy...@lge.com<mailto:reza.suy...@lge.com> [belajar-excel]" <belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com>> menulis: Pagi Pak Ivan Coba ditambahin fungsi counta dan ditambah 8 sebagai colom pertama pengisian data. Sub Rectangle6_Click() Range("h2:ae8").ClearContents Application.ScreenUpdating = False Dim lastRow As Long, i As Long, j As Long Dim jml As Integer lastRow = 597 j = 1 For x = 2 To 7 For i = 1 To lastRow If InStr(Sheets(2).Range("B" & i).Value, Cells(x, 2).Value) Then jml = Application.WorksheetFunction.CountA(Sheets(3).Range(Cells(x, 8), Cells(x, 31))) jml = jml + 8 Sheets(2).Cells(i, 3).Copy Destination:=Sheets(3).Cells(x, jml) j = j + 1 End If Next i Next x Application.ScreenUpdating = True End Sub Salam Yono From: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> [mailto:belajar-excel@yahoogroups.com] Sent: Monday, October 05, 2015 11:03 PM To: belajar-excel@yahoogroups.com<mailto:belajar-excel@yahoogroups.com> Subject: [belajar-excel] tolong dibantu perbaiki rumus makro vbanya... [1 Attachment] hello master2 excel.. ini saya lg coba2 rumus vba cuman vba untuk tombol updatenya saya rasa lom sempurna... sekiranya tolong dibantu diperbaiki supaya jadi sempurna...file saya lampirkan... thx