Makro: læse dato fra filer og kopiere til excel i rækkefølge

Dette script piller det største timestamp ud. Det kræver at formatet på filen altid er som beskrevet.

Dim fso As Object, folder As Object, file As Object, maxDate As String, currentDate As String
Set fso = CreateObject("scripting.filesystemobject")
Set folder = fso.getFolder("C:\Documents and Settings\bogsted\Desktop\System\asdfasdf")
For Each file In folder.Files
    currentDate = Left(Mid(file.Name, 26), 14)
    If maxDate = "" Then
        maxDate = currentDate
    Else
        If currentDate > maxDate Then
            MsgBox ("N9999REPORT.13MTH________" & maxDate & ".txt har ikke det største timestamp")
            maxDate = currentDate
        End If
    End If
Next
If maxDate <> "" Then
    MsgBox ("N9999REPORT.13MTH________" & maxDate & ".txt har det største timestamp")
End If

Det er et fint script der kan se forskellen på de to filer som den skal. Hvordan skal makroen udbygges således at den også sætter den fil med det mindste timestamp ind i sheet "Download_current" og filen med den største timestamp ind i sheet "Download_prev"??

Sætter ind? indholdet eller filenavnet?

Og skal den overskrive tidligere data i de ark?

Den skal indsætte indholdet af filen; og overskrive tidligere data.

Hvis du vil have et eksempel på en fil, må du sende din mail...

Udskriver hver linje i filen på hver sin række i arket.

Option Explicit
Function loadStatus()
    Dim fso As Object, folder As Object, file As Object, maxDate As String, currentDate As String, folderPath As String
    Set fso = CreateObject("scripting.filesystemobject")
    folderPath = "Z:\regnskab\"
    Set folder = fso.getFolder(folderPath)
    For Each file In folder.Files
        currentDate = Left(Mid(file.Name, 26), 14)
        If maxDate = "" Then
            maxDate = currentDate
        Else
            If currentDate > maxDate Then
                writeContent Sheets("Download_prev"), folderPath & "\N9999REPORT.13MTH________" & maxDate & ".txt"
                maxDate = currentDate
            End If
        End If
    Next
    If maxDate <> "" Then
        writeContent Sheets("Download__Current"), folderPath & "\N9999REPORT.13MTH________" & maxDate & ".txt"
    End If
End Function
Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    Dim fso As Object, file As Object, row As Integer
    Set fso = CreateObject("scripting.filesystemobject")
   
    sheet.Cells.Clear
    Set file = fso.openTextFile(fileName)
    row = 1
    Do While Not file.AtEndOfStream
        sheet.Cells(row, 1).Value = file.readline
        row = row + 1
    Loop
End Function

Jeg tror den er lige ved at være der, men den txt fil som der skal læse fra er semikolon-delimited - så derfor går det ikke at lade den skrive linje for linje. (uden at tage højde for dette)

Sorry jeg ikke fik det med før!

jeg har ikke testet, men prøv dette

Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    Dim fso As Object, file As Object, row As Integer
    Dim Data As Variant' NY
    Set fso = CreateObject("scripting.filesystemobject")
 
    sheet.Cells.Clear
    Set file = fso.openTextFile(fileName)
    row = 1
    Do While Not file.AtEndOfStream
    Data = Split(file.readline, ";")'NY
        sheet.Range(Cells(row, 1), Cells(rw, UBound(Data) + 1)).Value = Application.WorksheetFunction.Transpose(Data)'RETTET
        row = row + 1
    Loop
End Function

Der er en fejl i denne linje:

sheet.Range(Cells(row, 1), Cells(row, UBound(Data) + 1)).Value = Application.WorksheetFunction.Transpose(Data)'RETTET

En såkaldt "Application-defined or object-defined error"

Jeg er ikke god nok til VBA til at jeg selv kan se hvor den er gal, så håber rigtig meget på hjælp!!! :-)

sheet.Range(Cells(row, 1), Cells(row, UBound(Data) + 1))= Application.WorksheetFunction.Transpose(Data)

Jeg har fjernet .Value, se om det hjælper

Samme fejl fremkommer...

Det må være småting, men er ked af at jeg ikke selv kan se...

Option Explicit
Function loadStatus()
    Dim fso As Object, folder As Object, file As Object, maxDate As String, currentDate As String, folderPath As String
    Set fso = CreateObject("scripting.filesystemobject")
    folderPath = "C:\Data"
    Set folder = fso.getFolder(folderPath)
    For Each file In folder.Files
        currentDate = Left(Mid(file.Name, 26), 14)
        If maxDate = "" Then
            maxDate = currentDate
        Else
            If currentDate > maxDate Then
                writeContent Sheets("Download_prev"), folderPath & "\N9999REPORT.13MTH________" & maxDate & ".txt"
                maxDate = currentDate
            End If
        End If
    Next
    If maxDate <> "" Then
        writeContent Sheets("Download__Current"), folderPath & "\N9999REPORT.13MTH________" & maxDate & ".txt"
    End If
End Function

Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    Dim fso As Object, file As Object, row As Integer
    Dim Data As Variant    ' NY
    Set fso = CreateObject("scripting.filesystemobject")
    sheet.Cells.Clear
    Set file = fso.openTextFile(fileName)
    row = 1
    Do While Not file.AtEndOfStream
        Data = Split(file.readline, ";")    'NY
        sheet.Range(Cells(row, 1), Cells(row, UBound(Data) + 1)) = Data    'RETTET
        row = row + 1
    Loop
End Function

Nu skriver koden indholdet af filen ind, men den skriver kun den ene fil ind, så kommer samme fejl som tidligere.

Desuden skriver den linjerne ind, men ikke helt som hvis man bruger "Text import Wizard", da man gennem denne også kan gengive en såkaldt "Text qualifer" - i dette tilfælde er ". Jeg kunne godt tænke mig at koden gjorde det på samme måde, da der er en del tal i og disse skal kunne læses af resten af filen. Det er ikke tilfældet nu.

Igen må i sige til hvis i vil have en kopi af filerne - så i kan se hvad jeg mener. Hvis i mener at der snart er brug for flere point må i meget gerne sige til.. Det ville være klasse at få koden til at fungere.

Du kan optage en macro, importere en af dine filer, som du manuelt ville gøre. Så kan du bare smide det ind i writeContent og bruge file og sheet parametrerne i stedet for det, macrooptagelsen har genereret..

Hvis du har problemer, kan du bare paste den optagede macro ind.

/1.

Og med ind mener jeg herind..

Det bliver jeg nød til...

Option Explicit
Function loadStatus()
    Dim fso As Object, folder As Object, file As Object, regnr As String, maxdate As String, currentDate As String, folderpath As String
    Set fso = CreateObject("scripting.filesystemobject")
    folderpath = "Z:\Regnskab"
    Set folder = fso.getFolder(folderpath)
    regnr = Range("c14")
    For Each file In folder.Files
        currentDate = Left(Mid(file.Name, 26), 14)
        If maxdate = "" Then
            maxdate = currentDate
        Else
            If currentDate > maxdate Then
                writeContent Sheets("Download_prev_year"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
                maxdate = currentDate
            End If
        End If
    Next
    If maxdate <> "" Then
        writeContent Sheets("Download"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
    End If
End Function

Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    Dim fso As Object, file As Object, row As Integer, filepath As String
    Dim Data As Variant, maxdate As String    ' NY
    Set fso = CreateObject("scripting.filesystemobject")
    sheet.Cells.Clear
    Set file = fso.openTextFile(fileName)
    Workbooks.OpenText fileName:= _
        folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt", Origin:=-535, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
        Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _
        Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1)), _
        TrailingMinusNumbers:=True
End Function

Kan i se hvad der er galt??? Den siger at folderpath ikke er defineret som varibel...

Måske noget i denne retning?

Option Explicit
Function loadStatus()
    Dim fso As Object, folder As Object, file As Object, regnr As String, maxdate As String, currentDate As String, folderpath As String
    Set fso = CreateObject("scripting.filesystemobject")
    folderpath = "Z:\Regnskab"
    Set folder = fso.getFolder(folderpath)
    regnr = Range("c14")
    For Each file In folder.Files
        currentDate = Left(Mid(file.Name, 26), 14)
        If maxdate = "" Then
            maxdate = currentDate
        Else
            If currentDate > maxdate Then
                writeContent Sheets("Download_prev_year"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
                maxdate = currentDate
            End If
        End If
    Next
    If maxdate <> "" Then
        writeContent Sheets("Download"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
    End If
End Function
Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    sheet.Select
    Workbooks.OpenText _
        fileName:=fileName, _
        Origin:=-535, _
        StartRow:=1, _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=False, _
        Semicolon:=True, _
        Comma:=False, _
        Space:=False, _
        Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1)), _
        TrailingMinusNumbers:=True
End Function

Den åbner godt nok den ene fil, men den bliver aldrig kopieret over. Efter at filen åbner kommer fejlen "Application-defined or object-defined error"

I hvilken del af koden kopiere og indsætter den data?

Ok - den åbner tekstfilen som et excel ark..

Så skulle dette kunne gøre det.

Function loadStatus()
    Dim fso As Object, folder As Object, file As Object, regnr As String, maxdate As String, currentDate As String, folderpath As String
    Set fso = CreateObject("scripting.filesystemobject")
    folderpath = "Z:\Regnskab"
    Set folder = fso.getFolder(folderpath)
    regnr = Range("c14")
    For Each file In folder.Files
        currentDate = Left(Mid(file.Name, 26), 14)
        If maxdate = "" Then
            maxdate = currentDate
        Else
            If currentDate > maxdate Then
                writeContent Sheets("Download_prev_year"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
                maxdate = currentDate
            End If
        End If
    Next
    If maxdate <> "" Then
        writeContent Sheets("Download"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
    End If
End Function
Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    Application.DisplayAlerts = False
    Workbooks.OpenText _
        fileName:=fileName, _
        Origin:=-535, _
        StartRow:=1, _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=False, _
        Semicolon:=True, _
        Comma:=False, _
        Space:=False, _
        Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1)), _
        TrailingMinusNumbers:=True
    ActiveSheet.Cells.Copy
    sheet.Paste
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Function

Koden kører igennem uden fejl, men den kopiere desværre ikke det rigtige. Jeg har en forside, hvor jeg har tænkt at der skal være en knap der aktivere koden. Derfor kører jeg altid koden fra denne side. Problemet er imidlertid at koden kopierer denne forside og sætter dette ind i de to faner (Download_prev & Download_curr). Det er jo givetvis noget med ActiveSheet.Cells.Copy der fejler...

Aprospos knappen på forsiden. Jeg er vant til at arbejde med moduler og kan derfor relativt let linke en makro til en knap - men jeg kan se at når der er tale om Function, ser det ud til at det er noget andet man skal gøre.. Kan du også hjælpe med dette?

På forhånd mange tak!

Hvad hedder det sheet (ark), som der skal kopieres fra?

Når du skal assigne en funktion, skal du bare skrive navnet - funktioner bliver ikke vist, men kan alligevel assignes.
Alternativt kan du lave funktionen om til en sub (Function loadStatus() -> Sub loadStatus()) - så kan du se den som du plejer.

Arket som der skal kopieres fra hedder
& regnr & "REPORT.13MTH________"& 200708

(hvilket jo er lige med N9999REPORT.13MTH________ og en forkortelse af resten af navnet)

Kan man evt omdøbe det ark som der skal kopieres fra inden så det altid vil lykkes, selvom man skifter regnr eller måned?

Tak for svaret til knap. Skylder snart mange point!!!

Hvis det er ark nummer 2 - og altid er nummer 2, kan du referere til det med index i stedet for navn..

Option Explicit
Function loadStatus()
    Dim fso As Object, folder As Object, file As Object, regnr As String, maxdate As String, currentDate As String, folderpath As String
    Set fso = CreateObject("scripting.filesystemobject")
    folderpath = "Z:\Regnskab"
    Set folder = fso.getFolder(folderpath)
    regnr = Range("c14")
    For Each file In folder.Files
        currentDate = Left(Mid(file.Name, 26), 14)
        If maxdate = "" Then
            maxdate = currentDate
        Else
            If currentDate > maxdate Then
                writeContent Sheets("Download_prev_year"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
                maxdate = currentDate
            End If
        End If
    Next
    If maxdate <> "" Then
        writeContent Sheets("Download"), folderpath & "\" & regnr & "REPORT.13MTH________" & maxdate & ".txt"
    End If
End Function
Function writeContent(ByRef sheet As Worksheet, ByVal fileName As String)
    Application.DisplayAlerts = False
    Workbooks.OpenText _
        fileName:=fileName, _
        Origin:=-535, _
        StartRow:=1, _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=False, _
        Semicolon:=True, _
        Comma:=False, _
        Space:=False, _
        Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1)), _
        TrailingMinusNumbers:=True
    Sheets(2).Cells.Copy
    sheet.Paste
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Function

Det er jeg med på, men arket vil ikke altid hedde to. Arket vil hedde det samme som filen indtil det 31. bogstav. Derfor vil en fil der hedder
N9999REPORT.13MTH________20070814066646 have et ark der hedder
N9999REPORT.13MTH________200708

Det er det jeg synes der gør det lidt tricky, da arknavnet derfor tit vil ændre sig!

Hvis du som i mit eksempel refererer med index nummer, vil du få ark nummer 2 og ikke et ark, der hedder 2.

Du kan jo altid prøve scriptet og vende tilbage, hvis det ikke virker..

Løsningsforslag efter at have set på filerne m.v.

Const testSti = "Z:\"

Const currentSheet = "Download"
Const prevSheet = "Download_Prev_year"

Dim fil1 As String, fil2 As String, stamp1 As String, stamp2 As String
Dim ræk, ciff5
Public Sub UdførImport()
Dim fso As Object, folder As Object, file As Object, maxDate As String, currentDate As String
Dim count
Rem Udtræk den valgte 5-ciff. gruppe
    ciff5 = ActiveWorkbook.Sheets("Front page").Cells(15, 3)

Rem Afbryd skærm-opdatering
    Application.ScreenUpdating = False

    count = 0
    Set fso = CreateObject("scripting.filesystemobject")
    Set folder = fso.getFolder(testSti)
   
    For Each file In folder.Files
Rem test om de 2 filer findes i Z-drev
        If Left(file.Name, 5) = ciff5 Then
            If count = 0 Then
                fil1 = file.Name
                stamp1 = Left(Mid(file.Name, 26), 14)
            Else
                If count = 1 Then
                    fil2 = file.Name
                    stamp2 = Left(Mid(file.Name, 26), 14)
                End If
            End If
            count = count + 1
        End If
    Next
   
Rem Er de 2 filer fundet?
    If count = 2 Then
        currentnr = sammenLign(stamp1, stamp2)
       
        If currentnr = 1 Then
            ImportFil fil1, currentSheet
            ImportFil fil2, prevSheet
        Else
            ImportFil fil2, currentSheet
            ImportFil fil2, prevSheet
        End If
       
        MsgBox ("Import er udført - sletter filer på Z-drev:" + vbCr + vbCr + _
            testSti + fil1 + vbCr + vbCr + _
            testSti + fil2)
           
On Error GoTo kanEjSletteFil                          'hvis fil ej kan slettes
        Kill testSti + fil1
        Kill testSti + fil2
    Else
        MsgBox ("Der blev søgt 2 filer - antalet af fundne filer er: " + CStr(count))
    End If
   
Rem Skærm-opdatering sættes tiligen
    Application.ScreenUpdating = True

    Exit Sub

kanEjSletteFil:
    Msg = "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Err.Description
    MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext

    Resume Next
End Sub
Private Function sammenLign(st1, st2)
    If Val(st1) < Val(st2) Then
        sammenLign = 1
    Else
        sammenLign = 2
    End If
End Function
Private Sub ImportFil(filnavn, ark)
    ActiveWorkbook.Sheets(ark).Activate
    ActiveSheet.Cells.Select                                    'slet gl. indhold
    Selection.Delete Shift:=xlUp
    ActiveSheet.Cells(1, 1).Select
   
    ræk = 1
    count = 1
   
    Open testSti + "\" + filnavn For Input As #1
        While Not EOF(1)
            Line Input #1, linie
           
            adskilLinie linie + ";", ark
            count = count + 1
        Wend
        Close #1
End Sub
Private Sub adskilLinie(linie, ark)
Dim lin, kol, p
    kol = 1
    While InStr(linie, ";") > 0
        p = InStr(linie, ";")
        If p > 0 Then
            felt = Left(linie, p - 1)
           
Rem Fjern anførselsTegn fra tekstfelter
            If InStr(felt, Chr(34)) > 0 Then
                felt = Replace(felt, Chr(34), "", 1, Len(felt))
            Else
                If felt <> "" Then
                    felt = ombytTegn(felt)
                End If
            End If
           
            ActiveWorkbook.Sheets(ark).Cells(ræk, kol) = felt
            kol = kol + 1
            linie = Mid(linie, p + 1)
        Else
            MsgBox ("Fejl i tekst-fil - kontakt udvikler")
            Exit Sub
        End If
    Wend
    ræk = ræk + 1
End Sub
Private Function ombytTegn(felt)
Dim redFelt, tegn
    redFelt = ""
   
    For f = 1 To Len(felt)
        tegn = Mid(felt, f, 1)
        If tegn = "." Then
            redFelt = redFelt + ","
        Else
            If tegn = "," Then
                redFelt = redFelt + "."
            Else
                redFelt = redFelt + tegn
            End If
        End If
    Next f
    ombytTegn = redFelt
End Function