Oprettet man. d. 19. november 2012 kl. 23:04:54

uglyo_o
uglyo_o (10.510 point. Point ude: 630)


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 :)!

Skrevet tir. d. 20. november 2012 kl. 09:27:07| #1

PBChristensen
PBChristensen (6.500 point)
Hej,

Kan ikke hjælpe dig med automatisk at hente data, men det kan være, at dette kan hjælpe med sti-problemet.

Her henter den data fra en undermappe (Data), men det kan du bare undlade:

Sub Read()
    Dim myPath As String
        myPath = ActiveWorkbook.Path
    Dim fnavn As String
    Dim strPath As String
    Dim strFileName As String
'Udskift stien med den ønskede sti
If Len(Dir(myPath & "\Data\", vbDirectory)) = 0 Then
    MkDir myPath & "\Data\"
End If
strPath = myPath & "\Data\"

    Application.DisplayAlerts = False
ChDir (strPath)
  Dim sFile As String
  Dim sText1 As String, sText2 As String, sText3 As String, sText4 As String, sText5 As String, sText6 As String, _
  sText7 As String, sText8 As String, sText10 As Currency, sText11 As Currency
  Dim iFilenum As Integer

  sFile = strPath & "Data.txt"

  iFilenum = FreeFile
  Open sFile For Input As iFilenum
  Input #iFilenum, sText1, sText2, sText3, sText4, sText5, sText6, sText7, sText8, sText10, sText11
  Close #iFilenum
Range("A1") = sText1
Range("B1") = sText2
Range("C1") = sText3
Range("D1") = sText4
Range("E1") = sText5
Range("F1") = sText6
Range("G1") = sText7
Range("H1") = sText8
Range("I1") = sText10
Range("J1") = sText11
End Sub

Skrevet tir. d. 20. november 2012 kl. 12:20:25| #2

uglyo_o
uglyo_o (10.510 point)
Fra en undermappe ville heller ikke gøre noget.
Jeg ser på det når jeg kommer hjem, men takker for input :)

Skrevet tir. d. 20. november 2012 kl. 21:11:50| #3

uglyo_o
uglyo_o (10.510 point)
Får fejl ved:

Input #iFilenum, sText1, sText2, sText3, sText4, sText5, sText6, sText7, sText8, sText10, sText11

Run-time error '62':
input past end of file

Skrevet tir. d. 20. november 2012 kl. 21:30:27| #4

uglyo_o
uglyo_o (10.510 point)
Har fundet ud af det,
Det står for hver ligne.
Kan godt bruge af den har en under mappe.
den finder filen ved bestemt navn i undermappen.

men kunne være godt hvis man kunne få den til af læse nyeste fil via. jo højere tal. fks. Update V. 1.0.0
Og så af den poster fra start A1 og til der ikke er flere ligner i excel filen, hvor med den os springer tomme ligner ovre i .txt filen.

og af det måske var automatisk,
men prøver af se om andre har input, ellers må jeg evt. prøve af lege med den du postede. :)

Skrevet ons. d. 21. november 2012 kl. 15:05:06| #5

uglyo_o
uglyo_o (10.510 point)
Ingen andre der har inputs :)?

Skrevet tor. d. 22. november 2012 kl. 23:56:37| #6

uglyo_o
uglyo_o (10.510 point)
Hvis det ikke er muligt,
kan man så fks. skrive i en kolone, fks. D1:D20
om hvilke navne filen kunne hedde, & dermed går VBA koden først ind og søger idette punkt D1:D20 og finder det, og dermed henter data i excel.

fks. i kolone D1:D20 filerne kan komme til af hedde.

Update V. 1.0.0
Update V. 1.0.1
Update V. 1.0.2
Update V. 1.0.3
Update V. 1.0.4
Update V. 1.0.5
Update V. 1.0.6
Update V. 1.0.7
Update V. 1.0.8
Update V. 1.0.9
Update V. 1.1.0
Update V. 1.1.1

Så hvis man putter update v. 1.0.0 vil den vælge den.
Men hvis der kommer en fil der hedder update v. 1.0.6 skal den tage den.
Men kommer der fks. en der ikke står i kolonen, så skal den komme op med en fejl. :)

Skrevet tir. d. 24. december 2013 kl. 17:35:42| #7


Skriv et indlæg




Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] [img]link til billede[/img]
Web- og emailadresser omdannes automatisk til links

Log ind

   


Seneste spørgsmål

Excel 2010, fanen Fomater findes ikke

Oprettet den 24. oktober 2014 kl. 12.32
knagen7100 giver 60 point for svar | Giv et svar »

VBA til at erstatte tekst

Oprettet den 24. oktober 2014 kl. 11.48
mrkr giver 200 point for svar | Giv et svar »

Sumtotal helst som en vba løsning.

Oprettet den 23. oktober 2014 kl. 22.16
hubertus giver 100 point for svar | Giv et svar »

Seneste guides

Find ejeren af et vilkårligt domæne
Undgå reklamerne på iPad
Opret BOOTBAR USB pen ...





Computerworld

Teaser billede

Android L: Disse telefoner får den nye version af Android

Den nyeste version af Android, Android Lollipop, er blevet præsenteret og er nu kommet ud i prøveversion til nogle enkelte enheder, men hvilke smartphones vil rent faktisk få det nye system?

CIO

Teaser billede

Microsoft: Adgang til Windows 10 vil kræve flere koder

I et forsøg på at appellere til de sikkerheds-bekymrede it-chefer indbygger Microsoft to-faktor-autentifikation direkte i Windows 10, som vil kræve to koder at få adgang til. Også en række andre...

Comon

Teaser billede

Test: Mini-computer fra Gigabyte har overraskende meget kraft

Gigabyte's Brix Pro (GB-BXi7-4770R) har overraskende meget kraft i så lille et chassis, men størrelsen giver også problemer.

Channelworld

Teaser billede

Printbranchen er ved at save benene af sig selv

Stenhård priskonkurrence undergraver den traditionelle forretningsmodel for salg af print-og kopimaskiner.

White paper

Teaser billede

It-ledelse i trange tider

Læs her hvordan it-ledelsen kan skabe omkostningsbesparelser og optimere virksomhedens arbejdsgange.



Udgiver · © 2014 Computerworld A/S · Hørkær 18 · 2730 Herlev · Tlf.: 77 300 300 · Fax: 77 300 301 · Brug af personoplysninger