makro til at hente data fra tekstfil

prøv lige at sende mig een af dine tekstfiler

excel@tbdl.dk

Revideret udgave:
Const startRæk = 7
Const startKol = 3
Dim pakkenr
Dim sti
Private Sub findsti()
    sti = ActiveWorkbook.Path
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
End Sub
Private Sub indlæsFil()
Dim ræk, linie
    On Error GoTo filFejl
   
    Open sti + pakkenr + ".txt" For Input As #1
   
    ræk = startRæk
    While Not EOF(1)
        Line Input #1, linie
        Cells(ræk, startKol) = hentVnr(linie)
        ræk = ræk + 1
    Wend
   
    Close (1)
    Exit Sub
   
filFejl:
    MsgBox ("Tekstfilen " + CStr(pakkenr) + " kan ikke findes!")
End Sub
Private Function hentVnr(linie)
    For f = 1 To 10
        p = InStr(linie, ";")
        linie = Mid(linie, p + 1)
    Next f
   
    p = InStr(linie, ";")
    hentVnr = Left(linie, p - 1)
End Function
Private Sub worksheet_change(ByVal target As Excel.Range)
Dim r, k
    findsti

    If target.Row = 3 And target.Column = 3 Then
        pakkenr = CStr(Cells(3, 3))
        If pakkenr <> "" Then
            indlæsFil
        End If
    End If
End Sub

Prøv at teste denne, den skal i arkmodulet, for det ark som tastes i.


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$C$3" Then
        Dim Sti As String, RW As Long, Linie As String
        Sti = "H:\\pakkeinstruktioner\TEST af makro\0"
        Open Sti & Target & ".txt" For Input As #1

        RW = 6
        While Not EOF(1)
            Line Input #1, Linie
            Cells(RW, "C") = Split(Linie, ";")(11)
            RW = RW + 1
        Wend
        Close (1)
    End If
End Sub

da den ikke er testet, skal
    Cells(RW, "C") = Split(Linie, ";")(11)
måske være

    Cells(RW, "C") = Split(Linie, ";")(10)

denne er også fejl
  Sti = "H:\\pakkeinstruktioner\TEST af makro\0"
skal være
  Sti = "H:\pakkeinstruktioner\TEST af makro\0"

hel ny

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$C$3" Then
        Dim Sti As String, RW As Long, Linie As String
        Sti = "H:\pakkeinstruktioner\TEST af makro\0"
        Open Sti & Target & ".txt" For Input As #1

        RW = 7
        While Not EOF(1)
            Line Input #1, Linie
            Cells(RW, "C") = Split(Linie, ";")(10)
            RW = RW + 1
        Wend
        Close (1)
    End If
End Sub

hmm intet af det virker overhovedet nu
Kabbak hos din kommer der en fejlmeddelelse Sibscript out of range ved linien Cells(RW, "C") = split(linie,";"(10)

Ved supertekst kommer fejlmeddelsen fra filfejl.

LN

hmm nu får jeg Kabbak's til at virke lidt

Det var en fejl 40 selvfølgelig

Men men men. Jeg har tre filer jeg tester på en med en linie, en med 3 linier og en med 15 linier

Tester jeg den med 15 linier
Og derefter den med 1 linie.
Bliver de sidste 14 linie stadifg stående, så der skal på en måde slettes når næste pakkenr indtastes.
Er dette muligt?

Og så en ting mere. Ved ikke om det er et ekstra spm - så opretter jeg bare et nyt ;O)

De værdier der kommer, Ser således ud "811XXXXXXX"
eller "812xxxxxxxxx" 6-8 x'er

Jeg skal egentlig kun bruge x-erne dvs uden feks "811"
Måske er det letter på alm formelniveau?

LN

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$C$3" Then
        Dim Sti As String, RW As Long, Linie As String

      Range("C7:C100").ClearContents' tømmer fra C7 til C100 inden koden køres

        Sti = "H:\pakkeinstruktioner\TEST af makro\0"
        Open Sti & Target & ".txt" For Input As #1

        RW = 7
        While Not EOF(1)
            Line Input #1, Linie
            Cells(RW, "C") = Split(Linie, ";")(10)
            RW = RW + 1
        Wend
        Close (1)
    End If
End Sub

Til det sidste du spørger om
  Cells(RW, "C") = Right(Split(Linie, ";")(10), (Len(Split(Linie, ";")(10)) - 3))

Ok så langt så godt Kabbak.

Den tager dog stadig det første 1 tal med og til slut er "
Det første et tal har jeg fået slettet ved at erstatte -3 med -4 men der er stadig det sidste "

Den slette felter helt perfekt inden koden køres

Hvor lægger jeg en fellmeddelse ind i tilfælde af at jeg taster et pakkenr der ikke eksisterer?

LN
LN

Cells(RW, "C") = trim(Right(Split(Linie, ";")(10), (Len(Split(Linie, ";")(10)) - 4)))

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$C$3" Then
        Dim Sti As String, RW As Long, Linie As String
        Range("C7:C100").ClearContents    ' tømmer fra C7 til C100 inden koden køres
        Sti = "H:\pakkeinstruktioner\TEST af makro\0"
        If Dir(Sti & Target & ".txt") <> "" Then    ' tjekker om filer eksisterer
            Open Sti & Target & ".txt" For Input As #1
            RW = 7
            While Not EOF(1)
                Line Input #1, Linie
                Cells(RW, "C") = Trim(Right(Split(Linie, ";")(10), (Len(Split(Linie, ";")(10)) - 4)))
                RW = RW + 1
            Wend
            Close (1)
        Else
            MsgBox " Filen findes ikke"
        End If
    End If
End Sub

hmm den tager stadig det sidste " med.

fejlmeddelselsen fungerer perfekt tak
LN

Hvis nummeret er tal, så prøv

    Cells(RW, "C") = Val(Trim(Right(Split(Linie, ";")(10), (Len(Split(Linie, ";")(10)) - 4))))

det var simpelten genialt

Du får point
Måske du kunne lægge et svar ind på mit tidligere spm omhandlende det samme. Så splitter jeg de 200 point derfra mellem dig og supertekst

Men du må lie komme med et svar begge steder.

Kommer med et spørgsmål mere om lidt for det er nemlig således at der både er et kunde nummer og et pakkenummer og på en eller anden måde skal der lægges noget ind så man skal ændre begge hvis man ændrer en - for at minimere fejlmulighederne. desværre står kundenummeret ikke i min pakkefil.
Men opretter et nyt spm vedr dette.

LN

der er nok point på dette spørgsmål,du må finde ud af hvad du gør med det andet, jeg skal ikke have del i dem.
;-))

Ok så kan du tjene nogle billige point på et spm meget lig dette jeg stiller om lidt.

Det er bare en nogle andre værdier de skal ind i D kolonnen men der er igen probklemer med bla ""

Det kommer lige straks


LN