Ticker

6/recent/ticker-posts

Cara Ekspor Data Dari Listview ke Excel Vb 6

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
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

Post a Comment

2 Comments

  1. Sangat menginspirasi mbak... mampir juga yaa ke blog kami di http://flashcomindonesia.com/kursus-excel-macro-di-surabaya.html

    ReplyDelete