Hent data fra en .txt fil med VBA/Makro
Jeg skal bruge en kode der kan hente og indsætte det i excel.Excel filen og .txt filen ligger i samme mappe.
Men kan lige ledes ligge på skrivebordet, som et andet sted.
Så jeg tænkte på om man kan lave en VBA/Makro kode der bare henter data når der dukker en .txt fil op i samme mappe som excel filen.
Gerne hvor med af selve .txt filen kan hedde noget forskelligt.
Er dette muligt?
Den jeg har fundet.
Den henter data fint. Men den skal bruge en "Sti" for af kunne finde det. fks. når man laver .bat fil kan man indtaste *.*.txt også fks. flytter den alle, eller åbner alle .txt filer.
Er der nogle bestemte tegn som kan gøre dette i VBA/Makro?
Sub ImportDelimitedText()
'Importerer teksten adskilt af sSepChar i sSourceFile til
'Range(sTargetAddress). Overskriver ældre data.
'Normalt vil denne procedure blive kaldt af en anden,
'som så samtidig videregiver info om tekstfilens navn
'og sti (sSourceFile), separatortegn (sSepChar) og evt.
'celleadressen (sTargetSddress), hvor teksten skal sættes ind.
Dim sDel As String * 1
Dim LineString As String
Dim sSourceFile As String
Dim sSepChar As String
Dim sTargetAddress As String
Dim rTargetCell As Range
Dim vTargetValues As Variant
Dim r As Long
Dim fLen As Long
Dim fn As Integer
On Error GoTo ErrorHandle
'Importfilen og dens placering
sSourceFile = "C:\Stien Til Filen"
'Separatortegn (delimiter)
sSepChar = ";"
'Startcelle for placering af data
sTargetAddress = "A1"
'sSourceFile eksisterer ikke
If Len(Dir(sSourceFile)) = 0 Then Exit Sub
'Identificerer delimiter
If UCase(sSepChar) = "TAB" Or UCase(sSepChar) = "T" Then
sDel = Chr(9)
Else
sDel = Left(sSepChar, 1)
End If
'Importér data
Worksheets(1).Activate
'Sætter startcellens adresse
Set rTargetCell = Range(sTargetAddress).Cells(1, 1)
'Sletter evt. gamle data
rTargetCell.CurrentRegion.Clear
On Error GoTo BeforeExit
'Får et frit nummer af operativsystemet
fn = FreeFile
'Åbner filen for input
Open sSourceFile For Input As #fn
On Error GoTo 0
fLen = LOF(fn)
r = 0
While Not EOF(fn)
Line Input #fn, LineString
'Kalder funktionen, som skal læse teksten.
vTargetValues = ParseDelimitedString(LineString, sSepChar)
'Skriver til celler
UpdateCells rTargetCell.Offset(r, 0), vTargetValues
r = r + 1
Wend
'Lukker tekstfilen
Close #fn
BeforeExit: 'Rydder op
Set rTargetCell = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Fejl i ImportDelimitedText."
Resume BeforeExit
End Sub
Function ParseDelimitedString(InputString As String, _
sDel As String) As Variant
'Returnerer et variant array indeholdende hvert element
'i InputString adskilt af sDel.
Dim i As Integer, iCount As Integer
Dim sString As String, sChar As String * 1
Dim ResultArray() As Variant
On Error GoTo ErrorHandle
sString = ""
iCount = 0
For i = 1 To Len(InputString)
sChar = Mid$(InputString, i, 1)
If sChar = sDel Then
iCount = iCount + 1
ReDim Preserve ResultArray(1 To iCount)
ResultArray(iCount) = sString
sString = ""
Else
sString = sString & sChar
End If
Next i
iCount = iCount + 1
ReDim Preserve ResultArray(1 To iCount)
ResultArray(iCount) = sString
ParseDelimitedString = ResultArray
Exit Function
ErrorHandle:
MsgBox Err.Description & " Fejl i funktionen ParseDelimitedString."
End Function
Sub UpdateCells(rTargetRange As Range, vTargetValues As Variant)
'Skriver indholdet i variablen vTargetValues
'til det aktive faneblad begyndende i rTargetRange.
'Eksisterende data overskrives.
Dim r As Long, c As Integer
On Error GoTo ErrorHandle
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
r = 1
c = 1
On Error Resume Next
c = UBound(vTargetValues, 1)
r = UBound(vTargetValues, 2)
Range(rTargetRange.Cells(1, 1), rTargetRange.Cells(1, 1). _
Offset(r - 1, c - 1)).Formula = vTargetValues
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Fejl i UpdateCells."
End Sub
Jeg takker på forhånd :)!