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: [email protected] [mailto:[email protected]]
Sent: Thursday, October 08, 2015 10:52 PM
To: [email protected]
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 [email protected] [belajar-excel]"
<[email protected]> 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 [email protected]<mailto:[email protected]>
[belajar-excel]
<[email protected]<mailto:[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]>
[mailto:[email protected]]
Sent: Tuesday, October 06, 2015 9:55 PM
To: [email protected]<mailto:[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]<mailto:[email protected]> [belajar-excel]"
<[email protected]<mailto:[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]<mailto:[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]<mailto:[email protected]> [belajar-excel]"
<[email protected]<mailto:[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]>
[mailto:[email protected]]
Sent: Tuesday, October 06, 2015 1:35 PM
To: [email protected]<mailto:[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]<mailto:[email protected]> [belajar-excel]"
<[email protected]<mailto:[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]>
[mailto:[email protected]]
Sent: Monday, October 05, 2015 11:03 PM
To: [email protected]<mailto:[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
