bisa tolong di posting contoh wbknya.. >>> yang kode vbanya gak mau jalan..
cukup beberapa baris data saja, ukuran <250 kb wassalam, -aji mumpung- Pada 18 Oktober 2012 11:35, luthfie_27 <[email protected]> menulis: > ** > > > ini macro saya copikan di excel yang laen gak mau,saya kasih warna merah > peruntah yg gak mau jalan.. > mohon dibantu > > > Sub AnalisaRAB() > > Dim hdIdAhsDtl, hdIdAhsRab As Range > > Dim idxRowDtl, idxRowAHS As Long > > Dim r, RecNo, Htg As Long > > > > Application.ScreenUpdating = False > > Set hdIdAhsDtl = Sheet2.Range("b9") > > If Sheet2.Range("b9").Value = "" Then > > MsgBox "Data detail ARB tidak ditemukan", vbOKOnly, "Pesan" > > Exit Sub > > End If > > Set hdIdAhsRab = Sheet1.Range("c6") > > idxRowAHS = Sheet1.Cells.SpecialCells(xlCellTypeLastCell).Row > > idxRowDtl = Sheet2.Cells.SpecialCells(xlCellTypeLastCell).Row > > For r = 9 To idxRowDtl > > Sheet2.Select > > If Cells(r, 2) = "" Then > > Cells(r, 11).Value = Cells(r - 1, 11).Value > > Else > > Cells(r, 11).Value = Cells(r - 1, 11).Value + 1 > > End If > > If Cells(r - 1, 11).Value = Cells(r, 11).Value Then > > Cells(r, 12).Value = Cells(r - 1, 12).Value > > Else > > Cells(r, 12).Value = > > Application.WorksheetFunction.Index(Range(Sheet1.Cells(6, 5), > > Sheet1.Cells(idxRowAHS, 5)), _ > > Application.WorksheetFunction.Match(Sheet2.Cells(r, 2), > > Range(Sheet1.Cells(6, 3), Sheet1.Cells(idxRowAHS, 3)), 0)) > > End If > > If Cells(r, 12).Value <> 0 Then > > Range(Cells(r, 2), Cells(r, 10)).Copy > > Sheet3.Select > > Range("c8").Select > > If ActiveCell.Offset(1, 0) = "" Then > > ActiveCell.Offset(1, -1).Select > > Else > > ActiveCell.End(xlDown).Offset(1, -1).Select > > End If > > ActiveCell.PasteSpecial (xlPasteValuesAndNumberFormats) > > Application.CutCopyMode = False > > End If > > Next r > > Sheet2.Select > > Range("k:l").Delete > > Application.ScreenUpdating = True > > End Sub > > > > --- In [email protected], aji mumpung <pupung1986@...> wrote: > > > > ikutan.. > > mungkin bukan solusi optimal, karena pake kolom bantu yang dijalankan > > dengan macro hehehe > > terakhir.. kolom bantunya dihapus lagi jadi di detail RAB bersih dari > kolom > > bantu > > > > cara ini terinspirasi dari solusi Master Kid yang sebelumnya menawarkan > > solusi dengan formula > > > > codenya ditulis dalam sebuah modul dan dijalankan dengan menekan sebuah > > tombol > > > > Option Explicit > > ' ====================================== > > ' coded by: Aji Mumpung > > ' terinspirasi dari formula master Kid > > ' kaki gunung merbabu, 17 Oktober 2012 > > ' sambil angon kambing & nyari rumput > > ' ====================================== > > Sub AnalisaRAB() > > Dim hdIdAhsDtl, hdIdAhsRab As Range > > Dim idxRowDtl, idxRowAHS As Long > > Dim r, RecNo, Htg As Long > > > > Application.ScreenUpdating = False > > Set hdIdAhsDtl = Sheet2.Range("b9") > > If Sheet2.Range("b9").Value = "" Then > > MsgBox "Data detail ARB tidak ditemukan", vbOKOnly, "Pesan" > > Exit Sub > > End If > > Set hdIdAhsRab = Sheet1.Range("c6") > > idxRowAHS = Sheet1.Cells.SpecialCells(xlCellTypeLastCell).Row > > idxRowDtl = Sheet2.Cells.SpecialCells(xlCellTypeLastCell).Row > > For r = 9 To idxRowDtl > > Sheet2.Select > > If Cells(r, 2) = "" Then > > Cells(r, 11).Value = Cells(r - 1, 11).Value > > Else > > Cells(r, 11).Value = Cells(r - 1, 11).Value + 1 > > End If > > If Cells(r - 1, 11).Value = Cells(r, 11).Value Then > > Cells(r, 12).Value = Cells(r - 1, 12).Value > > Else > > Cells(r, 12).Value = > > Application.WorksheetFunction.Index(Range(Sheet1.Cells(6, 5), > > Sheet1.Cells(idxRowAHS, 5)), _ > > Application.WorksheetFunction.Match(Sheet2.Cells(r, 2), > > Range(Sheet1.Cells(6, 3), Sheet1.Cells(idxRowAHS, 3)), 0)) > > End If > > If Cells(r, 12).Value <> 0 Then > > Range(Cells(r, 2), Cells(r, 10)).Copy > > Sheet3.Select > > Range("c8").Select > > If ActiveCell.Offset(1, 0) = "" Then > > ActiveCell.Offset(1, -1).Select > > Else > > ActiveCell.End(xlDown).Offset(1, -1).Select > > End If > > ActiveCell.PasteSpecial (xlPasteValuesAndNumberFormats) > > Application.CutCopyMode = False > > End If > > Next r > > Sheet2.Select > > Range("k:l").Delete > > Application.ScreenUpdating = True > > End Sub > > > > > > wassalam, > > > > -aji mumpung- > > #lagi angon sambil cari rumput# > > > > Pada 16 Oktober 2012 19:11, luthfi amin luthfie_27@... menulis: > > > > > ** > > > > > > > > > > waduh maaf master kid,filenya kegedean gak lihat,maklum baru jadi > > > anggota.. > > > > > > dengan solusi sumproduct sudah sangat membantu,tapi analisa saya banyak > > > master ada sekitar 650 analisa.. > > > > > > ada tidak formula atau macro yang lebih efektif?? > > > > > > trimakasih > > > > > > > > > > > > > >
