Waow.. Sempurna sekali rumusnya pak... Sesuai yg saya harapkan... Thx banget pak..
Sent from my PC > On 7 Okt 2015, at 08.21, SUYONO [email protected] [belajar-excel] > <[email protected]> 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: [email protected] [mailto:[email protected]] > Sent: Tuesday, October 06, 2015 9:55 PM > To: [email protected] > 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 [email protected] > [belajar-excel]" <[email protected]> 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 <[email protected]> > menulis: > > > > sudah saya coba hasilnya... sub or function not defined... kayaknya ada yg > salah nih.. > > > > > > Pada Selasa, 6 Oktober 2015 18:28, "SUYONO [email protected] > [belajar-excel]" <[email protected]> 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: [email protected] [mailto:[email protected]] > Sent: Tuesday, October 06, 2015 1:35 PM > To: [email protected] > 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 [email protected] > [belajar-excel]" <[email protected]> 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: [email protected] [mailto:[email protected]] > Sent: Monday, October 05, 2015 11:03 PM > To: [email protected] > 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 > > > > > > > > > > > > >
