Untuk mengekspor data dari listview ke Excel pada Vb 6 berikut tahapannya:
1. Aktifkan Reference Microsoft Excel xx.x Object Library dengan memilih tab Project >>Reference sehingga akan muncul gambar berikut
2. Tulis koding berikut
Sub ExportkeExcel()
On Error Resume Next
Screen.MousePointer = vbHourglass
Dim Rfs As Integer
Dim LstFld As Integer
Dim exc As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim k As Integer
Dim CLms As Integer
Dim no As Integer
'On Error GoTo 1
Set wb = exc.Workbooks.Add
Set ws = wb.Worksheets(1)
LstFld = 8 'Jumlah Collumn
ws.Cells.Clear
exc.Visible = True '<---- Merubah dari “ False” Export ke excel data
'On Error GoTo 1
For CLms = 1 To LstFld
ws.Cells(1, CLms).Font.Bold = True '<-- Bold
ws.Cells(1, CLms) = Me.LV.ColumnHeaders(CLms).Text '<---Menambahkan ListViewer column headers ke XL Sheet
ws.Cells(1, CLms).Font.Color = &H8000& '<--- Warna Hijau
ws.Cells(1, CLms).Interior.Color = vbGreen
Next CLms
'Menampilkan criteria selection
ws.Cells(2, 2) = "Selection : ******************"
ws.Cells(3, 2) = "Tanggal : ***" & Format(D1, "dd/mm/yyyy") & " --- s/d --- " & Format(D2, "dd/mm/yyyy")
ws.Cells(4, 2) = "Kelompok : ***" & Combo1.Text & ",----- Item --- : " & T1.Text & " - " & Label5.Caption
ws.Cells(2, 2).Font.Color = &H808000
ws.Cells(3, 2).Font.Color = &H808000
ws.Cells(4, 2).Font.Color = &H808000
Dim flds As Integer
Dim flds2 As Integer
Dim strFlds As String
flds2 = LstFld
For i = 1 To TraceItem.ListItems.Count
strFlds = ""
strFlds = Me.TraceItem.ListItems(i).Text
ws.Cells(i + 5, 1) = strFlds '<--- data export ke Excel sheet
For flds = 1 To flds2
strFlds = ""
strFlds = Me.TraceItem.ListItems(i).ListSubItems(flds).Text
ws.Cells(i + 5, flds + 1) = strFlds '<--- data export to Excel sheet
Next flds
Next i
'For CLms = 1 To LstFld
ws.Columns(1).AutoFit '<---Autofilt data on XL sheet
'Next CLms
'Menampilkan data non listview
ws.Cells(Me.LV.ListItems.Count + 8, 1) = "" '<---Bemberikan jarak pada baris terakhir
ws.Cells(Me.LV.ListItems.Count + 9, 2) = "Software by: Agoes Priyanto bocah Sragen"
ws.Cells(Me.LV.ListItems.Count + 10, 2) = "Export Data tanggal" & " " & Format(Now, "dd.mm.yyyy")
Dim clms1 As Integer
For clms1 = 1 To 9
ws.Cells(Me.LV.ListItems.Count + 8, 2).Font.Bold = True '<-- Bold
ws.Cells(Me.LV.ListItems.Count + 8, 2).Font.Color = &H808000 '<--- Green Color
ws.Cells(Me.LV.ListItems.Count + 9, 2).Font.Bold = True
ws.Cells(Me.LV.ListItems.Count + 9, 2).Font.Color = &H808000 '<--- Green Color
ws.Cells(Me.LV.ListItems.Count + 10, 2).Font.Bold = True
ws.Cells(Me.LV.ListItems.Count + 10, 2).Font.Color = &H808000 '<--- Green Color
Next clms1
ws.Name = Me.LV.Name '<----Nama Sheet
exc.Visible = True '<--- Membuka Excel sheet setelah Export
Set wb = Nothing 'Mengembalikan ke nilai awal
Set ws = Nothing 'sMengembalikan ke nilai awal
'1:
'MsgBox Err.Description, vbCritical, "Error " & Err.Number
Screen.MousePointer = vbDefault
Exit Sub
End Sub
3. Penjelasan : LV merupakan nama Listview, Bisa diubah menyesuaikan nama Listview Kalian
4. Untuk memanggil fungsi ini tinggal
Call ExportkeExcel
referensi : http://priyantoagoes.blogspot.co.id/2012/11/exportlistview-vb6database-accesskeexcel.html , http://www.vbforums.com/showthread.php?651712-RESOLVED-Error-Type-Excel-application-is-not-defined
1. Aktifkan Reference Microsoft Excel xx.x Object Library dengan memilih tab Project >>Reference sehingga akan muncul gambar berikut
Gambar : Memiilih References |
2. Tulis koding berikut
Sub ExportkeExcel()
On Error Resume Next
Screen.MousePointer = vbHourglass
Dim Rfs As Integer
Dim LstFld As Integer
Dim exc As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim k As Integer
Dim CLms As Integer
Dim no As Integer
'On Error GoTo 1
Set wb = exc.Workbooks.Add
Set ws = wb.Worksheets(1)
LstFld = 8 'Jumlah Collumn
ws.Cells.Clear
exc.Visible = True '<---- Merubah dari “ False” Export ke excel data
'On Error GoTo 1
For CLms = 1 To LstFld
ws.Cells(1, CLms).Font.Bold = True '<-- Bold
ws.Cells(1, CLms) = Me.LV.ColumnHeaders(CLms).Text '<---Menambahkan ListViewer column headers ke XL Sheet
ws.Cells(1, CLms).Font.Color = &H8000& '<--- Warna Hijau
ws.Cells(1, CLms).Interior.Color = vbGreen
Next CLms
'Menampilkan criteria selection
ws.Cells(2, 2) = "Selection : ******************"
ws.Cells(3, 2) = "Tanggal : ***" & Format(D1, "dd/mm/yyyy") & " --- s/d --- " & Format(D2, "dd/mm/yyyy")
ws.Cells(4, 2) = "Kelompok : ***" & Combo1.Text & ",----- Item --- : " & T1.Text & " - " & Label5.Caption
ws.Cells(2, 2).Font.Color = &H808000
ws.Cells(3, 2).Font.Color = &H808000
ws.Cells(4, 2).Font.Color = &H808000
Dim flds As Integer
Dim flds2 As Integer
Dim strFlds As String
flds2 = LstFld
For i = 1 To TraceItem.ListItems.Count
strFlds = ""
strFlds = Me.TraceItem.ListItems(i).Text
ws.Cells(i + 5, 1) = strFlds '<--- data export ke Excel sheet
For flds = 1 To flds2
strFlds = ""
strFlds = Me.TraceItem.ListItems(i).ListSubItems(flds).Text
ws.Cells(i + 5, flds + 1) = strFlds '<--- data export to Excel sheet
Next flds
Next i
'For CLms = 1 To LstFld
ws.Columns(1).AutoFit '<---Autofilt data on XL sheet
'Next CLms
'Menampilkan data non listview
ws.Cells(Me.LV.ListItems.Count + 8, 1) = "" '<---Bemberikan jarak pada baris terakhir
ws.Cells(Me.LV.ListItems.Count + 9, 2) = "Software by: Agoes Priyanto bocah Sragen"
ws.Cells(Me.LV.ListItems.Count + 10, 2) = "Export Data tanggal" & " " & Format(Now, "dd.mm.yyyy")
Dim clms1 As Integer
For clms1 = 1 To 9
ws.Cells(Me.LV.ListItems.Count + 8, 2).Font.Bold = True '<-- Bold
ws.Cells(Me.LV.ListItems.Count + 8, 2).Font.Color = &H808000 '<--- Green Color
ws.Cells(Me.LV.ListItems.Count + 9, 2).Font.Bold = True
ws.Cells(Me.LV.ListItems.Count + 9, 2).Font.Color = &H808000 '<--- Green Color
ws.Cells(Me.LV.ListItems.Count + 10, 2).Font.Bold = True
ws.Cells(Me.LV.ListItems.Count + 10, 2).Font.Color = &H808000 '<--- Green Color
Next clms1
ws.Name = Me.LV.Name '<----Nama Sheet
exc.Visible = True '<--- Membuka Excel sheet setelah Export
Set wb = Nothing 'Mengembalikan ke nilai awal
Set ws = Nothing 'sMengembalikan ke nilai awal
'1:
'MsgBox Err.Description, vbCritical, "Error " & Err.Number
Screen.MousePointer = vbDefault
Exit Sub
End Sub
3. Penjelasan : LV merupakan nama Listview, Bisa diubah menyesuaikan nama Listview Kalian
4. Untuk memanggil fungsi ini tinggal
Call ExportkeExcel
referensi : http://priyantoagoes.blogspot.co.id/2012/11/exportlistview-vb6database-accesskeexcel.html , http://www.vbforums.com/showthread.php?651712-RESOLVED-Error-Type-Excel-application-is-not-defined
2 Comments
Sangat menginspirasi mbak... mampir juga yaa ke blog kami di http://flashcomindonesia.com/kursus-excel-macro-di-surabaya.html
ReplyDeleteterimakasih. oke siapp
ReplyDelete