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

uglyo_o
uglyo_o (10.245 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.235 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.245 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.245 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.245 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.245 point)
Ingen andre der har inputs :)?

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

uglyo_o
uglyo_o (10.245 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

Hvem skal på sejrs-skamlen ?

Oprettet den 1. september 2014 kl. 12.20
folj giver 30 point for svar | Giv et svar »

Hvordan får jeg vist faner, der er låst med VBA

Oprettet den 1. september 2014 kl. 11.50
Officeren giver 30 point for svar | Giv et svar »

Timeregistrering - antal dage under 60

Oprettet den 1. september 2014 kl. 11.10
kaz9k giver 30 point for svar | Giv et svar »






Computerworld

Teaser billede

KMD-fyringer gennemført: Sådan ramte de organisationen

Dagens store fyringsrunde i KMD er nu gennemført. Se her, hvordan fyringerne ramte organisationen.

CIO

Teaser billede

It-projekterne fejler igen og igen: Forklaringen er ganske pinlig

It skal skabe mere effektive virksomheder og offentlige institutioner, men ender alt for ofte med at skabe problemer. Forklaringen bør give røde ører.

Comon

Teaser billede

Din indbakke har fået en ny hersker - her er det bedste mailprogram (til Mac)

Langt om længe er den hypede e-mail-app Mailbox kommet til din Mac. Og den har været værd at vente på.

Channelworld

Teaser billede

Installers' konkurs sender 25 it-folk hjem uden løn

Et halvt år med underskud på driften og millionslagsmål med en kunde tømte kassen hos it-firmaet Installers, som nu har kastet håndklædet i ringen.

White paper

Teaser billede

Vellykket konsolidering af datacentret

Få store besparelser ved downsizing og konsolidering af datacentret allerede i løbet af måneder. Læs her om fordelene.



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