Disse websidene oppdateres ikke lengre og er kun tilgjengelig for historikken sin skyld.

Klikk her for å gå til den oppdaterte informasjonen.

Importer data fra en tekstfil til flere regneark (ADO)

Prosedyren nedenfor kan brukes til å lage en dummy tekstfil som inneholder 1 000 000 semi-kolon separerte datarecords:

Sub CreateTextFileDB()
Dim strTextFile As String, f As Integer
Dim strItem1 As String, strItem2 As String
Dim i As Long, j As Long
    strTextFile = "C:\Temp\" & Format(Date, "yyyymmdd") & ".txt"
    On Error Resume Next
    Kill strTextFile
    On Error GoTo 0
    f = FreeFile
    Open strTextFile For Append As #f
    Print #f, "ITEM1;ITEM2;VALUEi;VALUEj;PRODUCT"
    For i = 1 To 100
        strItem1 = "ITEM" & Format(i, "000")
        Application.StatusBar = "Writing data for " & strItem1 & "..."
        For j = 1 To 10000
            strItem2 = "item" & Format(j, "00000")
            Print #f, strItem1 & ";" & strItem2 & ";" & i & ";" & j & ";" & i * j
        Next j
        DoEvents
    Next i
    Close #f
    Application.StatusBar = False
End Sub

Prosedyren nedenfor kan benyttes til å lese informasjon fra en tekstfil (slik som dummy-filen som lages av prosedyren ovenfor), og fyller inn dataene for hvert unike element i et felt/kolonne inn i jvert sitt regneark:

Sub CreateNewWorkbookFromTextFile(strFolder As String, strTextFile As String)
' brukes slik: CreateNewWorkbookFromTextFile "C:\Temp", "TextFileName.txt"
Dim cn As ADODB.Connection, rs As ADODB.Recordset, rsItems As ADODB.Recordset
Dim wb As Workbook, ws As Worksheet, i As Long, f As Long, strSQL As String
    If Len(strFolder) = 0 Then Exit Sub
    If Len(strTextFile) = 0 Then Exit Sub
    
    Set cn = New ADODB.Connection
    On Error Resume Next
    cn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
        "Dbq=" & strFolder & ";" & _
        "Extensions=asc,csv,tab,txt;"
    On Error GoTo 0
    If cn.State <> adStateOpen Then Exit Sub
    
    ' les inn alle unike elementer fra ett felt/kolonne
    Set rsItems = New ADODB.Recordset
    strSQL = "select distinct ITEM1 from " & strTextFile
    On Error Resume Next
    rsItems.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
    On Error GoTo 0
    If rsItems.State <> adStateOpen Then ' fant ingen data
        Set rsItems = Nothing
        cn.Close
        Set cn = Nothing
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    ' create a new workbook
    Set wb = Workbooks.Add
    
    i = 0
    Do While Not rsItems.EOF ' for hvert unike element i feltet
        Application.StatusBar = "Leser data for " & rsItems(0).Value & "..."
        i = i + 1
        strSQL = "select * from " & strTextFile & " where ITEM1 = '" & rsItems(0).Value & "'"
        Set rs = New ADODB.Recordset
        On Error Resume Next
        rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
        On Error GoTo 0
        If rs.State = adStateOpen Then
            Application.StatusBar = "Skriver data for " & rsItems(0).Value & "..."
            With wb
                If i > .Worksheets.Count Then ' legg til et nytt regneark
                    .Worksheets.Add After:=.Worksheets(.Worksheets.Count)
                End If
                With .Worksheets(i) ' fyll inn regnearket for elementet
                    ' feltoverskriftene
                    For f = 0 To rs.Fields.Count - 1
                        .Range("A1").Offset(0, f).Formula = rs.Fields(f).Name
                    Next f
                    .Rows(1).Font.Bold = True
                    ' dataene
                    .Range("A2").CopyFromRecordset rs, .Rows.Count - 1, Columns.Count
                    .Columns("A:IV").AutoFit
                End With
            End With
            rs.Close
        End If
        Set rs = Nothing
        rsItems.MoveNext
        Application.StatusBar = False
        DoEvents
    Loop
    rsItems.Close
    Set rsItems = Nothing
    cn.Close
    Set cn = Nothing
    wb.Worksheets(1).Activate
    Set wb = Nothing
    Application.ScreenUpdating = True
End Sub

Dersom du benytter prosedyren over til å lage dummy-filen med 1 000 000 records, kan du lage en arbeidsbok med 100 regneark med 10 000 records hver slik:

Sub TestCreateNewWorkbookFromTextFile()
    CreateNewWorkbookFromTextFile "C:\Temp", Format(Date, "yyyymmdd") & ".txt"
End Sub

Dette makroeksempelet forutsetter at ditt VBA prosjekt har en referanse til ADO objektbiblioteket.
Dette gjøres fra VBE ved å velge menyvalget Tools, References og velge Microsoft ActiveX Data Objects x.x Object Library.

Dokumentet er sist oppdatert 2004-12-17 20:28:48