Kalo boleh nimbrung .....
Public Sub ReadExcelFileDO()
On Error GoTo ErrorHandler ' Enable error-handling routine.
Dim objRsExcel As Object
Set objRsExcel = CreateObject("ADODB.Recordset")
Dim objRsExcelTemp As Object
Set objRsExcelTemp = CreateObject("ADODB.Recordset")
Dim objRsExcelCount As Object
Set objRsExcelCount = CreateObject("ADODB.Recordset")
Dim sConn As String
Dim strExcelPath As String
Dim lngTotalRows As Long
Dim dblAmountSum As Double
Dim dblPurchaseLedgerSum As Double
Dim dblSW As Double
Dim dblPAYENIC As Double
lngTotalRows = 0
dblAmountSum = 0
dblPurchaseLedgerSum = 0
dblSW = 0
dblPAYENIC = 0
strExcelPath = strFileExcel
objRsExcel.CursorLocation = 1
objRsExcel.CursorType = 1
objRsExcel.LockType = 1
objRsExcelTemp.CursorLocation = 1
objRsExcelTemp.CursorType = 1
objRsExcelTemp.LockType = 1
Screen.MousePointer = vbHourglass
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFileExcel &
";Extended Properties=Excel 3.0"
objRsExcel.Open "SELECT * FROM [" & strSheetName & "$]", sConn, 0
objRsExcelTemp.Open "SELECT * FROM [" & strSheetName & "$]", sConn, 0
objRsExcelCount.Open "SELECT Count(*) as TotCount FROM [" & strSheetName &
"$]", sConn, 0
'----- Columns excel --------------
MSFlexGrid1.Cols = objRsExcelTemp.Fields.Count + 1
MSFlexGrid1.ColWidth(0) = 500
MSFlexGrid1.TextMatrix(0, 0) = "#No"
MSFlexGrid1.GridLinesFixed = flexGridFlat
MSFlexGrid1.BackColorFixed = vbBlack
MSFlexGrid1.BackColorSel = vbBlue
MSFlexGrid1.BackColorBkg = vbWhite
MSFlexGrid1.ForeColorFixed = vbWhite
MSFlexGrid1.ForeColorSel = vbYellow
MSFlexGrid1.ForeColor = &H80&
MSFlexGrid1.Font.Bold = True
'--- Progress Bar
For I = 0 To objRsExcelTemp.Fields.Count - 1
'---- Contains Per Record/Columns
MSFlexGrid1.ColAlignment(I) = vbCenter
MSFlexGrid1.ColWidth(I + 1) = 1500
MSFlexGrid1.TextMatrix(0, I + 1) = objRsExcelTemp.Fields(I).Name
Next
Dim TotRecord As Long
TotRecord = objRsExcelCount.Fields(0)
objRsExcelCount.Close
Set objRsExcelCount = Nothing
MSFlexGrid1.Rows = TotRecord + 1
'--------------------------------------------------
MSFlexGrid1.Font.Bold = False
'-------- Ambil Datanya dan tampilkan ----------------------------
Dim sCount As Integer
sCount = 1
For x = 0 To objRsExcelTemp.Fields.Count - 1
I = 0
Do While Not objRsExcelTemp.EOF
If Not IsNull(Trim(objRsExcelTemp.Fields(x))) Then
MSFlexGrid1.TextMatrix(I, 0) = I
MSFlexGrid1.TextMatrix(I, x + 1) = objRsExcelTemp.Fields(x)
End If
I = I + 1
objRsExcelTemp.MoveNext
Loop
objRsExcelTemp.MoveFirst
Next x
objRsExcelTemp.Close
Set objRsExcelTemp = Nothing
objRsExcel.Close
Set objRsExcel = Nothing
Screen.MousePointer = vbDefault
MsgBox "Successfully Completed!", vbOKOnly + vbInformation, App.Title
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
''//Create Error Log File in Application Path
MsgBox "Error in Excel Sheet Data Row Number : " & lngTotalRows & vbCr &
"Error Number : " & err.Number & vbCr & "Error Description : " &
err.Description, vbCritical + vbOKOnly, App.Title
Open App.Path & "\" & "ImportExcelErrorFile.log" For Append As #1
Write #1, "Error Number : " & err.Number, "Error Description : " &
err.Description, Now ' Write comma-delimited data.
Close #1 ' Close before reopening in another mode.
'// Up to This
Screen.MousePointer = vbDefault
err.Clear
' 'End
End Sub
ali suparman <[EMAIL PROTECTED]> wrote:
Caba dari menu
Project -> References - > Microsoft Excel ...
trus check-nya diaktifkan
Jonathan Oei Joeng <[EMAIL PROTECTED]> wrote:
kok di VB saya tidak ada command excel.application ya ?
apakah itu add ins ?
jonathan
"Suseno" <[EMAIL PROTECTED]>
Sent by: [email protected] 19/02/2008 14:30 Please
respond to
[email protected]
To
<[email protected]> cc
Subject
RE: [Programmer-VB] Ambil data dari excel
Nih ada sample ambil data dr excel masuk ke flexgrid. Tapi kayaknya model
kolomnya beda dengan kasus mas jonatan.
Kl Contoh ini, kolomnya horosintal, datanya yang vertikal.
Sedangkan contoh data mas jonatan, kolomnya vertikal, datanya horisontal.
Ini bisa langsung input ke database atau masuk ke flexgrid dulu untuk cek data,
kl dah bener baru bikin looping insert ke database.
Silakan di modif aja. Semoga bermanfaat.
Dim x As Integer
Dim xlsApp As Excel.Application
Dim book As Excel.Workbook
Dim sheet As Excel.Worksheet
Set xlsApp = New Excel.Application
xlsApp.Visible = False
Set book = xlsApp.Workbooks.Open(App.Path & "\coba.xls")
Set sheet = book.Worksheets(1) 'Sheet 1
'Loop through cells to get data and modify data if you want to
For x = 1 To 600
t_nomor.Text = MSHFlexGrid1.ColSel
MSHFlexGrid1.TextMatrix(x, 1) = sheet.Cells(x, 1)
MSHFlexGrid1.TextMatrix(x, 2) = sheet.Cells(x, 2)
MSHFlexGrid1.TextMatrix(x, 3) = sheet.Cells(x, 3)
MSHFlexGrid1.TextMatrix(x, 4) = sheet.Cells(x, 4)
MSHFlexGrid1.TextMatrix(x, 5) = sheet.Cells(x, 5)
MSHFlexGrid1.TextMatrix(x, 6) = sheet.Cells(x, 6)
MSHFlexGrid1.TextMatrix(x, 7) = sheet.Cells(x, 7)
Next x
book.Close False 'Or True if you want to save changes
xlsApp.Quit
This communication may contain information that is legally proprietary,
confidential, or exempt from disclosure. If you are not the intended recipient,
please note that any dissemination, distribution, use or copying of this
communication is strictly prohibited. Anyone who receives this message in error
should notify the sender immediately by telephone +62-21-52961529 or by return
e-mail and delete it from his or her computer.
---------------------------------
Never miss a thing. Make Yahoo your homepage.
---------------------------------
Never miss a thing. Make Yahoo your homepage.
