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
