Makro og VBA - Lave TXT filer om og indsæt dem i excel

Print side | Luk vindue

Lave TXT filer om og indsæt dem i excel

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=3628
Udskrevet den: 21.Apr.2025 kl. 05:43

Emne: Lave TXT filer om og indsæt dem i excel

Besked fra: Bjerget
Emne: Lave TXT filer om og indsæt dem i excel
Posteringsdato: 22.Sep.2018 kl. 08:40

Hej søger lidt hjælp

Har et Excel ark med noget VBA i, hvor man laver en TXT fil om til en CSV fil,

en ad gangen, med vil gerne kunne lave alle TXT filer om på engang,

filerne vil ligge i den samme mappe som excel filen.

Jeg vil så også gerne have at den samle alle CSV filernes indhold og

sætte dem ind i mit ark fra med opstart fra celle B5 i Sheet1

uploads/2305/MEDLEM.ZIP" rel="nofollow - uploads/2305/MEDLEM.ZIP

Med venlig hilsen

Robert

Svar:

Besked fra: Bjarnehansen
Posteringsdato: 23.Sep.2018 kl. 18:30

https://central.xero.com/s/article/Convert-a-TXT-file-to-CSV-format%20" rel="nofollow - https://central.xero.com/s/article/Convert-a-TXT-file-to-CSV-format

-------------
Husk, at trykke på [Tak], hvis du kan lide et indlæg.
Husk, at trykke på [Accepteret Svar], hvis du kan bruge et løsningsforslag.
Med venlig hilsen - Bjarne Hansen - Microsoft 365 DK

Besked fra: Bjarnehansen
Posteringsdato: 23.Sep.2018 kl. 18:31

https://www.youtube.com/watch?v=r95iKz4wyYM%20" rel="nofollow - https://www.youtube.com/watch?v=r95iKz4wyYM

-------------
Husk, at trykke på [Tak], hvis du kan lide et indlæg.
Husk, at trykke på [Accepteret Svar], hvis du kan bruge et løsningsforslag.
Med venlig hilsen - Bjarne Hansen - Microsoft 365 DK

Besked fra: maxzpad
Posteringsdato: 24.Sep.2018 kl. 08:16

Hej Robert

Til at samle filerne (txt eller csv) ville jeg bruge Shell-kommandoen således:

    Dim varShell

    varShell = Shell("cmd /c copy /b C:\xyz\Test\*.csv C:\xyz\Test\newfile.csv", vbMinimizedNoFocus)

Mvh Max

Besked fra: Bjerget
Posteringsdato: 24.Sep.2018 kl. 21:55

Fandt denne løsning på samling af CSV filerne

Sub SamleFiler()

    Dim path            As String
    Dim FileName        As String
    Dim LastCell        As Range
    Dim Wkb            As Workbook
    Dim ws              As Worksheet
    Dim ThisWB          As String

    Dim sysXLS, tabel As Variant, ræk As Long, k As Long, antalKolonner As Long, antalK As Integer
    Dim linje As String

    Set sysXLS = ActiveWorkbook
    ræk = 1

    ThisWB = ThisWorkbook.Name
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = ActiveWorkbook.path & "\CSV\"

    FileName = Dir(path & "\*.csv", vbNormal)
    Do Until FileName = ""
        If FileName <> ThisWB Then
            Open path & "\" & FileName For Input As #1

            While Not EOF(1)
                Line Input #1, linje

                tabel = Split(linje, ";")
                antalK = UBound(tabel)

                For k = 1 To antalK
                    sysXLS.Sheets(1).Range("B5").Cells(ræk, k) = tabel(k - 1)
                Next k
                ræk = ræk + 1
            Wend
            Close #1
        End If
        sysXLS.Sheets(2).Columns.AutoFit
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing

    Set sysXLS = Nothing
End Sub

Besked fra: maxzpad
Posteringsdato: 25.Sep.2018 kl. 08:11

Og hvis den løsning virker for dit formål, skal du holde fast i den Smile

For mig ser selve kodningen dog helt unødvendigt "knudret" ud.

Mvh Max

Besked fra: Bjerget
Posteringsdato: 25.Sep.2018 kl. 08:21

Vi kære newbie tager jo nok nogle større omveje, da vi ikke er så kloge på VBA

men som du siger får jeg samlet mine CSV og indsat dem med start i min Celle "B5"

en dag lære jeg forhåbentligt at sætte de få linje ind så det kører uden de store omveje :)

Besked fra: maxzpad
Posteringsdato: 25.Sep.2018 kl. 08:56

Det er også helt fair Smile

Hovedsagen er jo, at det virker for dig.

Jeg har (uden at teste det lokalt hos mig selv) prøvet at indbygge min kode-stump i din nuværende løsning. Så "sparer" du et antal loops, da der kun skal hentes data fra én samlet fil.

Sub SamleFiler()

    Dim path            As String
    Dim FileName        As String
    Dim LastCell        As Range
    Dim Wkb            As Workbook
    Dim ws              As Worksheet
    Dim ThisWB          As String

    Dim sysXLS, tabel As Variant, ræk As Long, k As Long, antalKolonner As Long, antalK As Integer
    Dim linje As String

    Set sysXLS = ActiveWorkbook
    ræk = 1

    ThisWB = ThisWorkbook.Name
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = ActiveWorkbook.path & "\CSV\"

    ' Saml csv-filerne til én fil med navnet "samlet.csv" som ligger i din path
    Dim varShell
    varShell = Shell("cmd /c copy /b " & path & "*.csv " & path & "samlet.csv", vbMinimizedNoFocus)

    ' Sæt variablen FileName til navnet på den samlede csv-fil
    FileName = path & "samlet.csv"

    ' Her har jeg fjernet loopet med "Do until ..." fordi der nu kun er én samlet fil

            Open FileName For Input As #1

            While Not EOF(1)
                Line Input #1, linje

                tabel = Split(linje, ";")
                antalK = UBound(tabel)

                For k = 1 To antalK
                    sysXLS.Sheets(1).Range("B5").Cells(ræk, k) = tabel(k - 1)
                Next k
                ræk = ræk + 1
            Wend
            Close #1

        ' Er det ikke Sheets(1), som skal have auto-tilpasset kolonnebredderne?
        ' Data fra csv-filen indsættes i Sheets(1) - ikke Sheets(2) som angivet herunder
        sysXLS.Sheets(2).Columns.AutoFit

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing

    Set sysXLS = Nothing

End Sub

Du kan jo prøve det, hvis du har tid og lyst Smile

Mvh Max

Besked fra: Bjerget
Posteringsdato: 25.Sep.2018 kl. 09:41

Det virker fint Smile

Ang.

        ' Er det ikke Sheets(1), som skal have auto-tilpasset kolonnebredderne?
        ' Data fra csv-filen indsættes i Sheets(1) - ikke Sheets(2) som angivet herunder
        sysXLS.Sheets(2).Columns.AutoFit

er det fordi jeg ikke ønsker den ændre bredde i mine kolonne da den passer til et print i A4 liggende,

og ikke kunne finde en anden løsning

MVH

Robert

Besked fra: Bjerget
Posteringsdato: 25.Sep.2018 kl. 13:03

Så mangler jeg kun det sidste
VBA coden som jeg gerne vil ændre,
sådan at den tager alle TXT filer i en mappe
på engang og laver dem om til nogle CSV filer,
i stedet for at den kun tager en af gangen som man vælger nu

Sub ConvertToCSV()
    Dim filePath: filePath = GetFilePath()

    If filePath <> "" Then

        Dim sCurrentLine, sTextHead As String, sText2 As String, iSectionLine As Integer
        Dim sText3 As String, sText4 As String, sText5 As String, sText6 As String

        Dim objFso As FileSystemObject: Set objFso = New FileSystemObject
        Set txtStream = objFso.OpenTextFile(filePath, ForReading, False)

        Dim baseName: baseName = objFso.GetBaseName(objFso.GetFile(filePath))

        ' Create a text file.
        Set tsFile = objFso.CreateTextFile(ThisWorkbook.path + "\CSV\" + (baseName) + ".CSV", True)

        Do While Not txtStream.AtEndOfStream
            sCurrentLine = txtStream.ReadLine

            If txtStream.Line = 4 Then
                sTextHead = sCurrentLine
            End If

            If (txtStream.Line > 9) Then
                If Left(sCurrentLine, 10) = "_______NEW" Then
                    iSectionLine = 0

                    For iNumber = iStart To (iStart)
                        tsFile.WriteLine (baseName & ";" & sText2 & ";" & sText3 & ";" & sText4 & ";" & sText5 & ";" & sText6 & ";" & sTextHead & ";")
                    Next
                Else
                    iSectionLine = iSectionLine + 1

                    If iSectionLine = 2 Then
                        sText2 = sCurrentLine
                    End If

                    If iSectionLine = 3 Then
                        sText3 = sCurrentLine
                    End If

                    If iSectionLine = 4 Then
                        sText4 = sCurrentLine
                    End If

                    If iSectionLine = 5 Then
                        sText5 = sCurrentLine
                        End If

                    If iSectionLine = 6 Then
                        sText6 = sCurrentLine
                    End If
                End If
            End If
        Loop
        ' Close data file.
        tsFile.Close
        txtStream.Close

        ' Create message.
        sMsg = "Konverteret til CSV-fil:" & vbNewLine & vbNewLine
        sMsg = sMsg & Trim(baseName) + ".CSV"

        ' Display message.
        MsgBox sMsg, vbInformation
    End If
End Sub

Function GetFilePath()
    ' Default return value.
    GetFilePath = ""

    ' Define the file dialog.
    Dim fileDialog As Office.fileDialog

    ' Create the file dialog.
    Set fd = Application.fileDialog(msoFileDialogFilePicker)

    With fd

        .AllowMultiSelect = False

        ' Set the title of the dialog box.
        .Title = "Please select the TXT-file."

        ' Clear out the current filters, and add our own.
        .Filters.Clear
        .Filters.Add "Data Files", "*.TXT"
        .Filters.Add "All Files", "*.*"

        ' Show the dialog box. If the .Show method returns True, the
        ' user picked at least one file. If the .Show method returns
        ' False, the user clicked Cancel.
        If .Show = True Then
            GetFilePath = .SelectedItems(1) 'replace txtFileName with your textbox
        End If
    End With
End Function

Print side | Luk vindue