try this sniffet..
<pre>
Private Sub ExportData()
If b_Work Then Exit Sub
cmdExport.Text = "&Cancel"
b_Work = True
Me.Cursor = Cursors.WaitCursor
Dim oldCI As System.Globalization.CultureInfo = System.Threading.Thread.CurrentThread.CurrentCulture
System.Threading.Thread.CurrentThread.CurrentCulture = New System.Globalization.CultureInfo("en-US")
Dim oXL As Excel.Application = Nothing
Dim oWBs As Excel.Workbooks = Nothing
Dim oWB As Excel.Workbook = Nothing
Dim oSheet As Excel.Worksheet = Nothing
oXL = New Excel.Application
oXL.Visible = False
oXL.UserControl = False
oXL.ScreenUpdating = False
oXL.DisplayAlerts = False
oWBs = oXL.Workbooks
Dim sKriteria As String = ""
If m_KdLokasi.Length < 8 Then
sKriteria = " WHERE ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]) LIKE '" & m_KdLokasi & "%' "
Else
sKriteria = " WHERE ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC])='" & m_KdLokasi.Substring(0, 8) & "' "
End If
Dim sNamaKec As ArrayList = GetQryField(" SELECT ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]) AS [KD_LOKASI], [KECAMATAN],[KD_KEC]" & _
" FROM [TB_KEC] " & sKriteria & " ORDER BY [KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC];")
For iKec As Integer = 0 To sNamaKec.Count - 1
If b_Cancel Then GoTo ErrCanceling
Dim MyArrKec() As String = sNamaKec(iKec)
Dim NamaFolder As String = m_Folder & "\"
If m_KdLokasi.Length < 10 Then
NamaFolder = m_Folder & "\" & MyArrKec(2).ToString & "-" & MyArrKec(1).ToString & "\"
End If
NamaFolder = Replace(NamaFolder, "\\", "\")
If Not System.IO.Directory.Exists(NamaFolder) Then
System.IO.Directory.CreateDirectory(NamaFolder)
End If
sKriteria = ""
If m_KdLokasi.Length < 10 Then
sKriteria = " WHERE ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC])='" & MyArrKec(0).ToString & "' "
Else
sKriteria = " WHERE ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL])='" & m_KdLokasi.Substring(0, 10) & "' "
End If
Dim sNamaKel As ArrayList = GetQryField( _
" SELECT ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL]) AS [KD_LOKASI], [KELURAHAN],[KD_KEL] " & _
" FROM [TB_KEL] " & sKriteria & _
" ORDER BY ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL]);")
For iKel As Integer = 0 To sNamaKel.Count - 1
Dim MyArrKel = sNamaKel(iKel)
Application.DoEvents()
If b_Cancel Then GoTo ErrCanceling
oXL.UserControl = False
oWB = oWBs.Open(MyPath() & "\PRINTOUT.XLT")
Dim NamaFile As String = MyArrKel(2) & "-" & MyArrKel(1)
If Not System.IO.File.Exists(NamaFolder & NamaFile & ".xlsx") Then
oWB.SaveAs(NamaFolder & NamaFile & ".xlsx")
Else
oWB.SaveAs(NamaFolder & NamaFile & "_" & TimeValue(Now).ToString("hhmmss") & ".xlsx")
End If
sKriteria = ""
If m_KdLokasi.Length < 12 Then
sKriteria = " WHERE ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL])='" & MyArrKel(0).ToString & "' "
Else
sKriteria = " WHERE ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL]+[KD_TPS])='" & m_KdLokasi.Substring(0, 12) & "' "
End If
Dim sNamaTPS As ArrayList = GetQryField( _
" SELECT ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL]+[KD_TPS]) AS [KD_LOKASI], [NAMA_TPS] ,[KD_TPS]" & _
" FROM [TB_TPS] " & sKriteria & _
" ORDER BY ([KD_PROP]+[KD_KAB]+[KD_DP]+[KD_KEC]+[KD_KEL]+[KD_TPS]);")
If m_KdLokasi.Length = 12 Then
For Each oSheet In oWB.Sheets
If (CInt(Val(Mid(oSheet.Name, 5, 2))) <> CInt(m_KdLokasi.Substring(11, 2))) Then
oSheet.Delete()
End If
Next
Else
For Each oSheet In oWB.Sheets
If (CInt(Val(Mid(oSheet.Name, 5, 2))) < 1) Or (CInt(Val(Mid(oSheet.Name, 5, 2))) > CInt(sNamaTPS.Count)) Then
If oSheet.Name <> "RKP_TPS" Then
oSheet.Delete()
End If
End If
Next
oSheet = oWB.Sheets("RKP_TPS")
oSheet.Activate()
oSheet.Range(oSheet.Cells(14 + CInt(sNamaTPS.Count), 1), oSheet.Cells(44, 6)).Value = ""
oSheet.Range(oSheet.Cells(14 + CInt(sNamaTPS.Count), 1), oSheet.Cells(44, 6)).Delete(Excel.XlDeleteShiftDirection.xlShiftUp)
End If
For iTps As Integer = 0 To sNamaTPS.Count - 1
Dim MyArrTPS = sNamaTPS(iTps)
Application.DoEvents()
If b_Cancel Then GoTo ErrCanceling
oSheet = oWB.Sheets("TPS-" & CInt(MyArrTPS(2)).ToString("00"))
oSheet.Activate()
oSheet.Cells(4, 3) = MyArrTPS(1) & " (" & Mid(MyArrTPS(0).ToString, MyArrTPS(0).ToString.Length - 1) & ")"
oSheet.Cells(5, 3) = MyArrKel(1) & " (" & Mid(MyArrKel(0).ToString, MyArrKel(0).ToString.Length - 1) & ")"
oSheet.Cells(6, 3) = MyArrKec(1) & " (" & Mid(MyArrKec(0).ToString, MyArrKec(0).ToString.Length - 1) & ")"
oSheet.Cells(4, 10) = "DAPIL-" & MyArrKec(0).Substring(4, 2) & " (" & MyArrKec(0).Substring(4, 2) & ")"
Using oCnDPT As SqlConnection = New SqlConnection(SQL_CONNECTION_STRING)
Using oCmd_DPT As SqlCommand = New SqlCommand( _
" SELECT * FROM [TB_PEMILIH] WHERE [KD_LOKASI]='" & MyArrTPS(0).ToString & "' " & _
" ORDER BY [KD_LOKASI],[NO_URUT];", oCnDPT)
oCnDPT.Open()
Dim rdr_DPT As SqlDataReader = oCmd_DPT.ExecuteReader
Dim rw As Integer = 0
Dim LastRow As Integer = 0
Dim NoUrut As Integer = 0
Do While rdr_DPT.Read()
Application.DoEvents()
wlProgress.Text = MyArrKel(1) & "\" & MyArrTPS(1) & vbCrLf & rdr_DPT.GetValue(1) & "-" & rdr_DPT.GetValue(4)
With oSheet
NoUrut = NoUrut + 1
If NoUrut > 1 Then
.Range(.Cells(12 + rw, 1), .Cells(12 + rw, 10)).Value = ""
End If
Dim sTmpNIK As String = Mid(rdr_DPT.GetValue(0), 1, 4) & Mid(rdr_DPT.GetValue(0), 7, 2)
Dim sTmpTgl As String = "0101001031"
Dim sNik As String = rdr_DPT.GetValue(2) & ""
sNik = Replace(sNik, " ", "")
sNik = Trim(Replace(sNik, "+", ""))
If IsDate(rdr_DPT.GetValue(5)) Then
sTmpTgl = Format(CDate(rdr_DPT.GetValue(5)), "ddMMyy") & "100"
If UCase(Trim(rdr_DPT.GetValue(8))) = "L" Then
sTmpTgl = sTmpTgl & "1"
Else
sTmpTgl = sTmpTgl & "2"
End If
End If
.Cells(12 + rw, 1) = NoUrut
If Len(sNik) < 16 Then
sTmpNIK = "'" & sTmpNIK & sTmpTgl
Else
sTmpNIK = "'" & sNik
End If
.Cells(12 + rw, 2) = sTmpNIK
.Cells(12 + rw, 3) = rdr_DPT.GetValue(3)
.Cells(12 + rw, 4) = rdr_DPT.GetValue(4) & ", " & rdr_DPT.GetDateTime(5).ToString("dd-MM-yyyy")
If Year(rdr_DPT.GetDateTime(5)) = 1900 Then
.Cells(12 + rw, 5) = "?"
Else
.Cells(12 + rw, 5) = rdr_DPT.GetValue(6)
End If
.Cells(12 + rw, 6) = UCase(Trim(rdr_DPT.GetValue(7)))
If UCase(Trim(rdr_DPT.GetValue(8))) = "L" Then
.Cells(12 + rw, 7) = "L"
Else
.Cells(12 + rw, 8) = "P"
End If
.Cells(12 + rw, 9) = rdr_DPT.GetValue(9)
.Cells(12 + rw, 10) = rdr_DPT.GetValue(10)
.Range(.Cells(12 + rw, 1), .Cells(12 + rw, 10)).Borders.LineStyle = 1
End With
LastRow = rw
rw = rw + 1
Loop
rdr_DPT.Close()
End Using
End Using
oWB.Save()
Next iTps
oWB.Save()
oWB.Close()
Application.DoEvents()
Next iKel
Next iKec
oXL.Visible = True
oXL.UserControl = True
oXL.Quit()
Dim z As Integer = 0
z = Marshal.FinalReleaseComObject(oSheet)
oSheet = Nothing
z = Marshal.FinalReleaseComObject(oWB)
oWB = Nothing
z = Marshal.FinalReleaseComObject(oWBs)
oWBs = Nothing
z = Marshal.FinalReleaseComObject(oXL)
oXL = Nothing
ErrCanceling:
If b_Cancel Then
MsgBox("Export dibatalkan", MsgBoxStyle.Critical, "Export to Excel")
End If
If Not oWB Is Nothing Then
oWB.Close(False)
oWB = Nothing
End If
If Not oXL Is Nothing Then
oXL.Quit()
oXL = Nothing
End If
System.Threading.Thread.CurrentThread.CurrentCulture = oldCI
Me.Cursor = Cursors.Default
cmdExport.Text = "&Export"
If b_Cancel Then
wlProgress.Text = "Export dibatalkan!"
Else
wlProgress.Text = "Export Complete!"
End If
b_Cancel = False
b_Work = False
End Sub
Private Sub cmdExport_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdExport.Click
If TxtFolder.Text = "" OrElse txtLokasi.Text = "" Then Exit Sub
If cmdExport.Text = "&Export" Then
If b_IsRekap Then
ExportRekap(KryptonRadioButton2.Checked)
Else
If KryptonCheckBox1.Visible And KryptonCheckBox1.Checked Then
_ExportData()
Else
ExportData()
End If
End If
Else
b_Cancel = True
End If
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
End Sub
maybe better...