Private Sub CmdExport_Click()
Dim x
Dim xlApp As Excel.Application
Dim xlBook As Workbook
Dim xl As Excel.Worksheet
Dim icols
Dim expDB As Database
Dim rs As Recordset
Dim FldCount As Integer
Dim rsCount As Integer
Dim i, k, c, r

x = MsgBox("Funktionen exporterar aktuella records från DBGrid till ett Excel ark, " &
"Saknas Excel på din dator blir det fel, vill du fortsätta?", vbYesNo + vbQuestion, _
"Exportera Data?")

If x = vbNo Then Exit Sub

If IsNull(tmpData.Recordset) Then GoTo NoRS
Screen.MousePointer = vbHourglass

Set rs = lstdb.OpenRecordset(tmpData.RecordSource, dbOpenSnapshot)

'Deklarerar applikationen
Set xlApp = CreateObject("Excel.Application")

'Deklarerar Workbook
Set xlBook = xlApp.Workbooks.Add(xlWBATWorksheet)

'Identifierar worksheet
Set xl = xlBook.Worksheets(1)

'Här kontrolleras antal kolumner samt namn. Denna kod
'finns i 'CopyFromRecordSet' funktionen i ett Excel objekt.

FldCount = rs.Fields.Count - 1
'Excel Column counts are kept seperate as fields may be skipped
c = 1
For icols = 0 To rs.Fields.Count - 1
'If the field is a system field then it skips it.
If rs.Fields(icols).Name Like "s_" & Chr(42) Then GoTo SkipName
xl.Cells(1, c).Value = rs.Fields(icols).Name
c = c + 1
SkipName:
Next

xl.Range(xl.Cells(1, 1), xl.Cells(1, rs.Fields.Count)).Font.Bold = True
With rs
.MoveLast
.MoveFirst
rsCount = .RecordCount - 1
r = 2
Me.Height = 5970

'Here I have a statusbar on my form
Bar1.Min = 0
Bar1.Max = rsCount
lblExport.Visible = True
Bar1.Visible = True

'4 loops are being performed at once here.
'Loop 'k' loops through the rows of records and
'with each row 'r' for the Excel sheet.

'Inside this loop is another nested loop.
'Loop 'i' is looping through the Fields and along
'with i 'c' is moving through the columns.

'As mentioned above the reason for seperate counts
'between the recordset and Excel sheet are due to
'skipping system fields.

For k = 0 To rsCount
c = 1
For i = 0 To FldCount
If rs.Fields(i).Name Like "s_" & Chr(42) Then GoTo SkipField
xl.Cells(r, c).Value = rs.Fields(i).Value
c = c + 1
SkipField:
Next 'i
r = r + 1
.MoveNext
Bar1.Value = k
Next 'k
End With

'After loop is complete, show the sheet
xl.Visible = xlSheetVisible
xlApp.Visible = True

Bar1.Visible = False
lblExport.Visible = False
Me.Height = 5265

xlApp.Quit
Set xl = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Set rs = Nothing
Screen.MousePointer = vbDefault
Exit Sub

NoRS:
Screen.MousePointer = vbDefault
MsgBox "Inga aktiva recordset funna"
Exit Sub

Exp_Err:
Screen.MousePointer = vbDefault
MsgBox Err.Number & ": " & Err.Description
Resume Next
End Sub