RE: [belajar-excel] Tanya Vba

['Kelik Pitoyo' ke...@shindengen.co.id [belajar-excel]]

Dear Mr. Kid

Selamat Siang,



Terima kasih atas masukannya,

Setelah saya copy dan sedikit otak atik, hasil dari script-nya belum sesuai 
keinginan,

Harusnya “Jasa Maklon” berada di antara kode supplier Part, seperti ini


3040025600


“Jasa Maklon”


3040025610

Berikut kami sampaikan file hasil dan script-nya,

Mohon dibantu perbaikannya di mana?



Terima kasih

Salam dan hormat kami,

Kelik



From: belajar-excel@yahoogroups.com [mailto:belajar-excel@yahoogroups.com]
Sent: Friday, March 16, 2018 7:33 AM
To: BeExcel
Subject: Re: [belajar-excel] Tanya Vba





Hai Kelik,

Asumsi :

1. Sudah ada workbook source yang terbuka bernama 'Source Format.xml' dengan 
data di sheet ke-1 (apapun namanya)

2. Sudah ada file lokasi paste bernama 'drive:\folder\subfolder\Book9.xlsx' 
walaupun belum terbuka, lokasi paste data di sheet ke-1 (apapun namanya)

3. Records yang di-copy dari source mulai baris ke-5 (berarti ada header di 
baris ke-4)

4. Kolom yang di-copy adalah C:F (4 kolom) dan kolom H (1 kolom) [kolom G tidak 
di-copy]

5. Lokasi paste sudah punya header di baris ke-6 [baris ke-5 adalah blank, dan 
lokasi paste di baris kosong pertama setelah header, tidak ada kolom yang 
di-hide]

6. Pengaturan paste untuk source kolom C:F di letakkan di lokasi paste kolom 
C:F, sedangkan source kolom G diletakkan di lokasi paste kolom i

7. Perlu membuat records baru untuk semua records hasil paste yang kolom F-nya 
berisi data dengan mengatur nilai kolom F records baru berbunyi 'Jasa Maklon' 
dan nilai kolom i records baru bernilai 500



Urutan proses manual :

1. copy dari source, kolom C:F (mulai baris 5 sampai baris terakhir), paste 
values ke lokasi target kolom C di baris baru

2. copy dari source, kolom H sebanyak baris records saat copy kolom C:F, paste 
values ke lokasi target kolom i dibaris lokasi paste kolom C:F

3. di hasil paste, pilih data hasil filter kolom F yang tidak kosong lalu copy 
(misal copy kolom C:E saja karena A:B kosong, F akan diganti, G kosong, i akan 
diganti),
    paste values ke baris baru setelah record terakhir yang ada

4. pada hasil paste hasil filter, nilai di kolom F diganti berbunyi 'Jassa 
Maklon', dan nilai kolom i diganti bernilai 500



Proses tersebut membutuhkan beberapa informasi yang harus terus dijaga untuk 
digunakan berulang kali, antara lain :

1. nomor baris Excel lokasi paste

2. jumlah records yang diproses

3. object worksheet source, workbook lokasi paste, dan object worksheet lokasi 
paste

Script :

0. deklarasi variabel dan init awal setiap variabel

dim shtS as worksheet, wbkT as workbook, shtT as worksheet, lRowNew as long, 
lRecords as long

set shts=workbooks("nama workbook source yang telah terbuka").sheets(1)

set wbkt=workbooks.open("drive:\folder\subfolder\Book9.xlsx")

set shts=wbkt.sheets(1)

lRowNew=shtt.cells( shtt.rows.count , "C" ).end(xlup).row+1   '+1 untuk 
mendapatkan baris kosong pertama

lRecords=shts.cells( shts.rows.count , "C" ).end(xlup).row-4   'header di baris 
4

if lrecords<1 then 'jika tidak ada record source, maka keluar
   exit sub

endif



1. copy paste dan flag penanda records baru hasil paste di kolom J

shts.range("C5:F5").resize( lrecords ).copy

shtt.cells( lrownew , "C" ).pastespecial xlpastevalues

shts.range("H5").resize( lrecords ).copy

shtt.cells( lrownew , "i" ).pastespecial xlpastevalues

shtt.cells( lrownew , "j" ).resize( lrecords ).value="Kid"

'shts.parent.close false   'tutup workbook source (aktifkan baris ini bila 
perlu)



2. set lokasi baris kosong untuk records baru 'Jasa Maklon'

lRowNew=shtt.cells( shtt..rows.count , "C" ).end(xlup).row+1   '+1 untuk 
mendapatkan baris kosong pertama



3. filter records baru hasil paste dengan kriteria kolom F yang tidak kosong, 
simpan jumlah records hasil filter,copy paste hasil filter ke baris baru

with shtt.range("a6").currentregion

    .autofilter 6,"<>"   'kriteria kolom F [6] tidak blank

    .autofilter 10,"Kid"  'kriteria kolom J [10] ada flag records baru

    lrecords=.resize(,1)...rows.count-1  'header tidak dihitung

    if lrecords<1 then   'tidak ada hasil filter

       .parent.autofiltermode=false  'turnoff autofilter

       .resize(,1).offset(9).clear   'hapus kolom flag, dari kolom A, 1 kolom, 
lompat 9 kolom ke kanan untuk sampai kolom ke-10 [J]

       exit sub

    endif

    .specialcells(xlcelltypevisible).copy .parent.cells( lrownew , "A" )

    .parent.autofiltermode=false  'turnoff autofilter

end with



4. set records 'Jasa Maklon' dengan nilai 500, lalu hapus kolom flag records 
baru (kolom J)

shtt.cells( lrownew , "F" ).resize( lrecords ).value="Jasa Maklon"

shtt.cells( lrownew , "i").resize( lrecords ).value=500

shtt.range("j6").resize( lrownew + lrecords ).clearcontents

'wbkt.save  'aktifkan bila perlu, atau saveas bila ingin dengan nama lain 
[awalnya, lokasi paste sudah ada dan hasil open workbook]



Regards,

Kid





2018-03-15 10:43 GMT+07:00 Kelikpitoyo kelikpit...@yahoo.com [belajar-excel] 
<belajar-excel@yahoogroups.com>:



Dear Masters,

Selamat Pagi,

Mohon dibantu,

saya belajar record macro, dari file "Source Format" saya mau copy paste ke 
file baru "Book9"

Namun saya tambahkan baris di tiap data yang saya copy, dengan menambahkan kata 
"Jasa Maklon" dan "500".

Jumlah baris data yang dicopy berubah-ubah,

Bagaimana bentuk script VBAnya? Untuk tidak menambahkan “Jasa Maklon” dan “500” 
saat tidak ada data yang dicopy,

mohon pencerahannya,

Berikut saya lampirkan:

file source = Source Format,

file hasil copy = Book9,  dan record makro nya,

Terima kasih sebelumnya,

Salam

Kelik

Book9.xlsx
Description: MS-Excel 2007 spreadsheet

Sub transpose_SO()
'Script:
'0. deklarasi variabel dan init awal setiap variabel
Dim shtS As Worksheet, wbkT As Workbook, shtT As Worksheet, lRowNew As Long, 
lRecords As Long
Set wbkT = Workbooks.Open("C:\Users\xxxx\Source.xml")
Set shtS = wbkT.Sheets(1)
Set wbkT = Workbooks.Open("C:\Users\xxxx\Book9.xlsx")
Set shtT = wbkT.Sheets(1)
lRowNew = shtT.Cells(shtT.Rows...Count, "C").End(xlUp).Row + 1  '+1 untuk 
mendapatkan baris kosong pertama
lRecords = shtS.Cells(shtS.Rows.Count, "C").End(xlUp).Row - 4  'header di baris 
4
If lRecords < 1 Then 'jika tidak ada record source, maka keluar
   Exit Sub
End If

'1. copy paste dan flag penanda records baru hasil paste di kolom J
shtS.Range("C5:F5").Resize(lRecords).Copy
shtT.Cells(lRowNew, "C").PasteSpecial xlPasteValues
shtS.Range("H5").Resize(lRecords).Copy
shtT.Cells(lRowNew, "i").PasteSpecial xlPasteValues
shtT.Cells(lRowNew, "j").Resize(lRecords).Value = "Kid"
shtS.Parent.Close False   'tutup workbook source (aktifkan baris ini bila perlu)

'2. set lokasi baris kosong untuk records baru 'Jasa Maklon'
lRowNew = shtT.Cells(shtT.Rows.Count, "C").End(xlUp).Row + 1  '+1 untuk 
mendapatkan baris kosong pertama


'3. filter records baru hasil paste dengan kriteria kolom F yang tidak kosong, 
simpan jumlah records hasil filter,copy paste hasil filter ke baris baru
With shtT.Range("a6").CurrentRegion
    .AutoFilter 6, "<>"  'kriteria kolom F [6] tidak blank
    .AutoFilter 10, "Kid" 'kriteria kolom J [10] ada flag records baru
    lRecords = .Resize(, 1).Rows.Count - 1 'header tidak dihitung
    If lRecords < 1 Then 'tidak ada hasil filter
       .Parent.AutoFilterMode = False 'turnoff autofilter
       .Resize(, 1).Offset(9).Clear  'hapus kolom flag, dari kolom A, 1 kolom, 
lompat 9 kolom ke kanan untuk sampai kolom ke-10 [J]
       Exit Sub
    End If
    .SpecialCells(xlCellTypeVisible).Copy .Parent.Cells(lRowNew, "A")
    .Parent.AutoFilterMode = False 'turnoff autofilter
End With

'4. set records 'Jasa Maklon' dengan nilai 500, lalu hapus kolom flag records 
baru (kolom J)
shtT.Cells(lRowNew, "F").Resize(lRecords).Value = "Jasa Maklon"
shtT.Cells(lRowNew, "i").Resize(lRecords).Value = 500
shtT.Range("j6").Resize(lRowNew + lRecords).ClearContents
wbkT.Save  'aktifkan bila perlu, atau saveas bila ingin dengan nama lain 
[awalnya, lokasi paste sudah ada dan hasil open workbook]
wbkT.Close

End Sub