Makro til import af flere filer

Funktion eller VBA?

VBA.
Jeg er ikke sikker på hvad du mener med funktion.

mvh Anker74

Rem Koden indsættes i ThisWorkbook"
Rem Udføres automatisk, når XLS-filen åbnes
Rem =======================================
Dim xsti, startRæk, startKol, slutRæk, slutKol      '2 sidstnævnte anvendes ikke p.t.
Private Sub workbook_activate()
    xsti = ActiveWorkbook.Path                      'alle filer i samme mappe .XLS + .txt
    If Right(xsti, 1) <> "\" Then
        xsti = xsti + "\"
    End If
   
    ActiveWorkbook.Sheets(1).Activate              'Ark1 aktiveres
   
    import "t1", "B4:E8"                            'områder kan tilpasses efter behov
    import "t2", "G4:J8"
    import "t3", "B11:E15"
    import "t4", "G11:J15"
   
    MsgBox ("Import udført")
End Sub
Private Sub import(filNavn, område)
Dim r, k
    findStart område, startRæk, startKol, slutRæk, slutKol
   
    r = startRæk
    k = startKol
   
    Open xsti + filNavn + ".txt" For Input As #1
    While Not EOF(1)
        Input #1, felt1, felt2, felt3, felt4
        Cells(r, k) = felt1
        Cells(r, k + 1) = felt2
        Cells(r, k + 2) = felt3
        Cells(r, k + 3) = felt4
        r = r + 1
    Wend
    Close #1
End Sub
Private Sub findStart(område, startRæk, startKol, slutRæk, slutKol)
Dim p, StartOmr, SlutOmr
    p = InStr(område, ":")
    If p > 0 Then
        StartOmr = Left(område, p - 1)
        startRæk = Range(StartOmr).Row
        startKol = Range(StartOmr).Column
       
        SlutOmr = Mid(område, p + 1)
        slutRæk = Range(SlutOmr).Row
        slutKol = Range(SlutOmr).Column
    Else
        Stop                                        ': ikke fundet
    End If
End Sub

Det ville være rigtigt godt hvis man selv fik lov til at vælge disse filer.
Og kan denne kode tilpasses således at den kan starte ved linje 3 i textfilen?

1) Skulle være muligt
2) De to første linier skal læses - uden at opdatere i XLS

Rem Koden indsættes i ThisWorkbook"
Rem Udføres automatisk, når XLS-filen åbnes
Rem version 2
Rem =======================================
Dim startRæk, startKol, slutRæk, slutKol        '2 sidstnævnte anvendes ikke p.t.
Private Sub workbook_activate()
   
    ActiveWorkbook.Sheets(1).Activate          'Ark1 aktiveres
       
    import "B4:E8"                              'områder kan tilpasses efter behov
    import "G4:J8"
    import "B11:E15"
    import "G11:J15"
   
    MsgBox ("Import udført")
End Sub
Private Function findFil()
    fileToOpen = Application _
        .GetOpenFilename("Text Files (*.txt), *.txt")
   
    If fileToOpen <> False Then
        findFil = fileToOpen
    Else
        findFil = ""
    End If
End Function
Private Sub import(område)
Dim r, k, filNavn

    filNavn = findFil
   
    If filNavn <> "" Then
        findStart område, startRæk, startKol, slutRæk, slutKol
       
        r = startRæk
        k = startKol
   
        Open filNavn For Input As #1
Rem Læs to første linier uden opdatering
            Input #1, felt1, felt2, felt3, felt4
            Input #1, felt1, felt2, felt3, felt4
           
        While Not EOF(1)
            Input #1, felt1, felt2, felt3, felt4
           
            Cells(r, k) = felt1
            Cells(r, k + 1) = felt2
            Cells(r, k + 2) = felt3
            Cells(r, k + 3) = felt4
            r = r + 1
        Wend
        Close #1
    End If
End Sub
Private Sub findStart(område, startRæk, startKol, slutRæk, slutKol)
Dim p, StartOmr, SlutOmr
    p = InStr(område, ":")
    If p > 0 Then
        StartOmr = Left(område, p - 1)
        startRæk = Range(StartOmr).Row
        startKol = Range(StartOmr).Column
       
        SlutOmr = Mid(område, p + 1)
        slutRæk = Range(SlutOmr).Row
        slutKol = Range(SlutOmr).Column
    Else
        Stop                                        ': ikke fundet
    End If
End Sub

Har du fået afprøvet sidste version?