Import af bestemte rækker fra tekstfil

Det kunne måske gøres med denne her makro (som ikke er testet)

Sub ReadFromFile()
'Læs fra en fil
    Const sFileName As String = "C:\WriteToFile.txt"
    Const lRowStart As Long = 60000
    Const lRowEnd As Long = 120000
    Const sDelimiter As String = " "
    Const sSheetName As String = "Ark1"
    Dim sLine As String
    Dim lFileNum As Long
    Dim lRow As Long: lRow = 0
    Dim sSplit As String
    Dim lCol As Long
    Dim lInsertRow As Long
   
    lInsertRow = Sheets(sSheetName).Range("A65536").End(xlUp).Row
    lFileNum = FreeFile
    Open sFileName For Input As #lFileNum
        Do While EOF(lFileNum) = False
            lRow = lRow + 1
            If lRow > lRowStart - 1 And lRow < lRowEnd + 1 Then
                Line Input #lFileNum, sLine
                sSplit = Split(sLine, sDelimiter)
                lInsertRow = lInsertRow + 1
                For lCol = LBound(sSplit) To UBound(sSplit)
                    Sheets(sSheetName).Cells(lInsertRow, lCol + 1).Value = sSplit(lCol)
                Next lCol
            Else
                If lRow > lRowEnd Then Exit Do
            End If
        Loop
    Close #lFileNum
End Sub

Får fejl her under LBound:
                For lCol = LBound(sSplit) To UBound(sSplit)
med beskeden, en matrix var ventet

prøv med
For lCol = 0 To UBound(sSplit)

Måske
Dim sSplit As String
skal være
Dim sSplit() As String

Får samme fejl som aheiss, men de nye rettelser hjælper ikke. Dvs. stadig fejl - en matrix var ventet. Det bør måske nævnes at split ikke er tilgængelig i excel97, hvorfor jeg anvender følgende function som har virket OK i tidligere makroer.


Function Split(sString As String, Optional sDelim As String = " ", _
  Optional ByVal Limit As Long = -1, _
  Optional Compare As Long = vbBinaryCompare) As Variant
''''''''''''''''''''''''''''
'  Split mirrors the Split function introduced in XL2000
'  Author Myrna Larson
'  posted to microsoft.public.excel.programming 13 Nov 2001
Dim vOut As Variant, StrLen As Long
Dim DelimLen As Long, Lim As Long
Dim n As Long, p1 As Long, p2 As Long

StrLen = Len(sString)
DelimLen = Len(sDelim)
ReDim vOut(0 To 0)
If StrLen = 0 Or Limit = 0 Then
' return array with 1 element which is empty
ElseIf DelimLen = 0 Then
    vOut(0) = sString ' return whole string in first array element
Else
    Limit = Limit - 1 ' adjust from count to offset
    n = -1
    p1 = 1
    Do While p1 <= StrLen
        p2 = InStr(p1, sString, sDelim, Compare)
        If p2 = 0 Then p2 = StrLen + 1
        n = n + 1
        If n > 0 Then ReDim Preserve vOut(0 To n)
        If n = Limit Then
            vOut(n) = Mid$(sString, p1) ' last element contains entire tail
            Exit Do
        Else
            vOut(n) = Mid$(sString, p1, p2 - p1) ' extract this piece of string
        End If
            p1 = p2 + DelimLen ' advance start past delimiter
    Loop
End If
Split = vOut
End Function

OK - Excel97....... hvem ville have gættet på det her 6 år senere *gg*

Dim sSplit as String........laves om til....... Dim vSplit As Variant .... eller .... Dim vSplit() As Variant

De steder  sSplit er anvendt bruges vSplit

Tester PT - uden error indtil videre. Men det er vist en kørsel der kan tage lidt tid eller hvad ?

Imens vi venter !
Overfører den en række ad gangen ? I så fald kan jeg vel afbryde med ESC, hvorefter jeg så gerne skulle have et regneark med x antal rækker data startende med text filens række 60000. Jeg er lidt bange for at det er en rigtig laang kørsel. Eller skulle den være hurtigere? Har pt. ventet ca.15 min.
Pentium3 1000htz ca.

Nix, der er noget galt. tekstfilimport er normalt lynende hurtig.

tryk ctrl+break og afbryd
Jeg gætter på at der lige skal byttes et par linier
Sub ReadFromFile()
'Læs fra en fil
    Const sFileName As String = "C:\WriteToFile.txt"
    Const lRowStart As Long = 60000
    Const lRowEnd As Long = 120000
    Const sDelimiter As String = " "
    Const sSheetName As String = "Ark1"
    Dim sLine As String
    Dim lFileNum As Long
    Dim lRow As Long: lRow = 0
    Dim sSplit As Variant
    Dim lCol As Long
    Dim lInsertRow As Long
   
    lInsertRow = Sheets(sSheetName).Range("A65536").End(xlUp).Row
    lFileNum = FreeFile
    Open sFileName For Input As #lFileNum
        Do While EOF(lFileNum) = False
                Line Input #lFileNum, sLine
                lRow = lRow + 1
                If lRow > lRowStart - 1 And lRow < lRowEnd + 1 Then
                    sSplit = Split(sLine, sDelimiter)
                    lInsertRow = lInsertRow + 1
                    For lCol = LBound(sSplit) To UBound(sSplit)
                        Sheets(sSheetName).Cells(lInsertRow, lCol + 1).Value = sSplit(lCol)
                    Next lCol
                Else
                    If lRow > lRowEnd Then Exit Do
                End If
        Loop
    Close #lFileNum
End Sub

tester, men jeg rettede ikke til vsplit og den har brugt over 1 minut !!

Det lykkes ikke. Den når aldrig at blive færdig ? Pt. ser koden således ud :

Sub ReadFromFile()
'Læs fra en fil
    Const sFileName As String = "E:\DAT\Db\App\IM_DAT.txt"
    Const lRowStart As Long = 60000
    Const lRowEnd As Long = 60001
    Const sDelimiter As String = " "
    Const sSheetName As String = "Ark1"
    Dim sLine As String
    Dim lFileNum As Long
    Dim lRow As Long: lRow = 0
'    Dim sSplit As Variant
    Dim vSplit As Variant
    Dim lCol As Long
    Dim lInsertRow As Long
   
    lInsertRow = Sheets(sSheetName).Range("A65536").End(xlUp).Row
    lFileNum = FreeFile
    Open sFileName For Input As #lFileNum
        Do While EOF(lFileNum) = False
                Line Input #lFileNum, sLine
                lRow = lRow + 1
                If lRow > lRowStart - 1 And lRow < lRowEnd + 1 Then
                    vSplit = Split(sLine, sDelimiter)
                    lInsertRow = lInsertRow + 1
                    For lCol = LBound(sSplit) To UBound(sSplit)
                        Sheets(sSheetName).Cells(lInsertRow, lCol + 1).Value = vSplit(lCol)
                    Next lCol
                Else
                    If lRow > lRowEnd Then Exit Do
                End If
        Loop
    Close #lFileNum
End Sub

Function Split(sString As String, Optional sDelim As String = " ", _
  Optional ByVal Limit As Long = -1, _
  Optional Compare As Long = vbBinaryCompare) As Variant
''''''''''''''''''''''''''''
'  Split mirrors the Split function introduced in XL2000
'  Author Myrna Larson
'  posted to microsoft.public.excel.programming 13 Nov 2001
Dim vOut As Variant, StrLen As Long
Dim DelimLen As Long, Lim As Long
Dim n As Long, p1 As Long, p2 As Long

StrLen = Len(sString)
DelimLen = Len(sDelim)
ReDim vOut(0 To 0)
If StrLen = 0 Or Limit = 0 Then
' return array with 1 element which is empty
ElseIf DelimLen = 0 Then
    vOut(0) = sString ' return whole string in first array element
Else
    Limit = Limit - 1 ' adjust from count to offset
    n = -1
    p1 = 1
    Do While p1 <= StrLen
        p2 = InStr(p1, sString, sDelim, Compare)
        If p2 = 0 Then p2 = StrLen + 1
        n = n + 1
        If n > 0 Then ReDim Preserve vOut(0 To n)
        If n = Limit Then
            vOut(n) = Mid$(sString, p1) ' last element contains entire tail
            Exit Do
        Else
            vOut(n) = Mid$(sString, p1, p2 - p1) ' extract this piece of string
        End If
            p1 = p2 + DelimLen ' advance start past delimiter
    Loop
End If
Split = vOut
End Function

OK Flemming og BAK. Jeg bliver nødt til at logge af for i dag. Tester forskeliige ting ud fra jeres bidrag senere - måske først mandag. Men tak for jeres bidrag....  håber at kunne dele lidt points ud senere (hvis) når det lykkes :-)

Lige for at give dig en ide om tidsforbrug.
Disse 11000 linier tager ca. 13 sekunder på en p1500


Sub ReadFromFile()
'Læs fra en fil
    Const sFileName As String = "C:\test123.txt"
    Const lRowStart As Long = 1000
    Const lRowEnd As Long = 12000
    Const sDelimiter As String = vbTab
    Const sSheetName As String = "Sheet1"
    Dim sLine As String
    Dim lFileNum As Long
    Dim lRow As Long
    Dim sSplit As Variant
    Dim lCol As Long
    Dim lInsertRow As Long
    Dim t As Long
    t = Timer
    lRow = 0
   
    lInsertRow = Sheets(sSheetName).Range("A65536").End(xlUp).Row
    lFileNum = FreeFile
    Open sFileName For Input As #lFileNum
    'sping over alle de første indtil lrowstart
    Do While Not (EOF(lFileNum) Or lRow > lRowStart)
        Line Input #lFileNum, sLine
        lRow = lRow + 1
    Loop
    'importer fra lrowstart til lrowend
    Do While Not (EOF(lFileNum) Or lRow > lRowEnd)
        sSplit = Split(sLine, sDelimiter)
        lInsertRow = lInsertRow + 1
        Sheets(sSheetName).Range(Cells(lInsertRow, 1), Cells(lInsertRow, UBound(sSplit) + 1)) = sSplit
        lRow = lRow + 1
    Loop
    Close #lFileNum
    MsgBox Timer - t
End Sub

tak bak - jeg var væk

Hurtigere!! , men knap så pæn
11000 linier på under 1 sek.

Sub ReadFromFilex()
'Læs fra en fil
    Const sFileName As String = "C:\test123.txt"
    Const lRowStart As Long = 1000
    Const lRowEnd As Long = 12000
    Const sDelimiter As String = vbTab
    Dim shName As Worksheet
    Dim y As Long
    Dim sLine As String
    Dim lFileNum As Long
    Dim lRow As Long
    Dim sSplit As Variant
    Dim lCol As Long
    Dim lInsertRow As Long
    Dim t As Long
    Dim vaTest()
    Set shName = Worksheets("sheet1")
    t = Timer
    lRow = 0
   
    lInsertRow = 0
    lFileNum = FreeFile
    Open sFileName For Input As #lFileNum
    'sping over alle de første indtil lrowstart
    Do While Not (EOF(lFileNum) Or lRow > lRowStart)
        Line Input #lFileNum, sLine
        lRow = lRow + 1
    Loop
    'importer fra lrowstart til lrowend
    lCol = UBound(Split(sLine, sDelimiter)) + 1
    ReDim vaTest(lRowEnd - lRowStart, lCol)
   
    Do While Not (EOF(lFileNum) Or lRow > lRowEnd)
        sSplit = Split(sLine, sDelimiter)
        lInsertRow = lInsertRow + 1
        For y = 0 To UBound(sSplit)
            vaTest(lInsertRow, y + 1) = sSplit(y)
        Next
       
        lRow = lRow + 1
       
    Loop
   
    Close #lFileNum
    shName.Range(shName.Cells(1, 1), shName.Cells(lInsertRow, lCol)) = vaTest
 
    MsgBox Timer - t
End Sub

Nu har jeg testet på min hjemme pc - excel2000. Her virker det hele ! Baks korrektioner øger hastigheden en del, dog skulle jeg indsætte :
        Line Input #lFileNum, sLine
-i det sidste Do Loop for at ikke samme tekstrække blev indsat i alle rækker.

Nu er jeg så lidt spændt på om jeg kan få det til at fungere på arbejde Excel97. Det virker fint hvis jeg bruger en "manuel" split funktion herhjemme!

Da jeg ikke er på arbejde før om 8 dage, vil jeg lige lukke spørgsmålet. Så opretter jeg et nyt Excel97 specifikt spørgsmål hvis det ikke virker. Jeg synes Flemming skal have 65 point for en udmærket løsning, og BAK 35 for diverse forbedringer. Bak sender du et svar.

Og så siger jeg tusind tak for hjælpen :-)

Selv tak, gad vide hvorfor den linie er gledet ud.... ?