Makro import af data!

Jeg er i tvivl, om du kan bruge bindestreg i
REG-KORT.A

Du skal nok bruge LIKE:
Like "*.A"

Men er .A extension ? Er det alt ?

Prøv at slette linje 4 - får også en fejlmelding (Excel 2007).

Jeg har prøvet at slette linje 4, hvorefter det virker. Så er det bare med at få programmet til at importerer alt fra en undermappe. Denne undermappe hedder eks. Data\ hvor i der er xx antal under mapper (M1, M2 osv) hvor der ligger en fil REG-FULD.A som skal importeres og sættes op i vilkårlig rækkefølge på samme ark.

En af mine problemstillinger ved denne import er bla. at der er mellemrum (altså rækker uden data) så koden  [ Selection.End(xlDown).Select ] hopper ikke helt til bunden. Det gør ikke noget hvis tomme rækker bliver sorteret fra under import, jeg har dog ikke nogen ide om hvordan dette gøres. (men det er vel det et forum er til for?)

Må heller tilføje at jeg har nået at få sorteret de tomme rækker fra. Det jeg mangler at knække er hvordan jeg søger efter alle filer i undermapper fra en given mappe og "nedad" i mappestien. Jeg vil gerne undgå at skrive c:\osv men kun have \data\

so far so good:

Sub importDATA()
'
' importDATA Makro
' Denne funktion indhenter data fra REG-FULD.A filer
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\....\Data behandling\Maskiner\M4\REG-FULD.A" _
        , Destination:=Range("$A$1"))
        .Name = "REG-FULD.A"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(9, 5, 1, 10)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
   
    Dim sidsteRække, række
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
   
    With ActiveSheet
    For række = sidsteRække To 1 Step -1
        If .Cells(række, 1) = "" Then
            .Rows(række).EntireRow.Delete
        End If
    Next række
  End With
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
       
End Sub

Lidt om traversering i mapper, undermapper med rekursiv funktion - dog med et lidt andet formål:

http://www.eksperten.dk/spm/916623

Hej Supertekst...

Jeg kan godt se du har lavet det før, men synes ik rigtig jeg kan få noget ud af det.

Jeg har fundet denne her: http://www.eksperten.dk/spm/754657 som du vist også har lavet. Den giver lidt mere mening, men skal bruge søge funktionen rundt i undermapperne, og hente alle filer med navnet: REG-FULD.A hvoraf det er kolonne A-D og x antal rækker der skal hentes. (eller alt hvad der står i dem er også fint!)

Hej

Traverseringen skal begynde i mappen Data. Heri traverseres alle mapper og alle filer i hver mappe med navnet REG-FULD.A skal "trækkes ud" . D.v.s. at for den enkelte fil kaldes import-rutinen med parametre for filSti & begyndelsesrække.

Det kunne være proceduren - eller?

Const drevSTi = "C:\Users\peter\Desktop\IndlæsTekstfil\Data"        'JUSTERES
Const filID = "REG-FULD.A"                                          '-"-
Dim rækNr As Integer, filnavn As String, mapNavn
Sub traverserData()
    rækNr = 1
    traverserMappe drevSTi, rækNr
End Sub
Private Sub traverserMappe(mappenavn, rækNr)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn)
    Set fc = f.SubFolders
   
    For Each f1 In fc
        mapNavn = f1.Name
        findFiler f1.Path, f1.Name, rækNr
    Next
End Sub
Private Sub findFiler(mappeSti, mappe, rækNr)
Dim fs, f, f1, fc, fNavn As String, ext As String, navnSplit As Variant

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappeSti)
    Set fc = f.Files
   
    For Each f1 In fc
        filnavn = f1.Name
        If InStr(filnavn, filID) = 1 Then
            importData mappeSti, filnavn, rækNr
            rækNr = ActiveCell.SpecialCells(xlLastCell).Row + 1
        End If
    Next
End Sub
Sub importData(mappeSti, filnavn, rækNr)
Dim lin As String
    lin = "TEXT;" & mappeSti & "\" & filnavn
    startAdr = "$A$" & CStr(rækNr)
       
    Application.ScreenUpdating = False
   
    With ActiveSheet.QueryTables.Add(Connection:= _
        lin, Destination:=Range(startAdr))
        .Name = "REG-FULD.A"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Hej Supertekst!

Jeg er pt på en anden haste opgave med nedbrud i en produktion. Jeg vil teste det i aften/morgen. Det ser jo ud som et plug and play program!

Tusind tak!

Hej

Ok og selv tak..

Åbner denne tråd igen.. :-(

Jeg har fået indsat koderne og kan godt se meningen/systemet. Dog har jeg lige et par enkelte spørgsmål:

Den øverste "sub" der hedder option explicit, skal den ikke være i et underprogram, altså inden for en Sub  _ Sub end ?? (melder dog ikke fejl)

fejl i
Private Sub findFiler(mappeSti, mappe, rækNr) ved linjen: ImportData MappeSti, filnavn, rækNr.java script: void(0);

For en fejl der hedder: Wrong number og argument or invalid property assignment
(sig til hvis jeg er for handicappet til at lave dette...)

Kan du evt gentage den fine formel du skrev og skrive  'JUSTERES ud fra de linjer jeg skal være opmærksom på, så tror jeg godt selv at jeg kan få den i hus!

Fra hjælp:

Example
This example uses the Option Explicit statement to force explicit declaration of all variables. Attempting to use an undeclared variable causes an error at compile time. The Option Explicit statement is used at the module level only.

Option explicit    ' Force explicit variable declaration.
Dim MyVar    ' Declare variable.
MyInt = 10    ' Undeclared variable generates error.
MyVar = 10    ' Declared variable does not generate error.

----

Private Sub findFiler(mappeSti, mappe, rækNr) ved linjen: ImportData MappeSti, filnavn, rækNr) <<----- skulle sluttes her

.java script: void(0);
hvor kommer dette fra?

Hjælper det??

Det ved jeg faktisk ik! det står heller ikke i mit program...

Private Sub findFiler(mappeSti, mappe, rækNr)
Dim fs, f, f1, fc, fNavn As String, ext As String, navnSplit As Variant

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappeSti)
    Set fc = f.Files
   
    For Each f1 In fc
        filnavn = f1.Name
        If InStr(filnavn, filID) = 1 Then
            importData mappeSti, filnavn, rækNr
            rækNr = ActiveCell.SpecialCells(xlLastCell).Row + 1
        End If
    Next
End Sub


og det er i linje 10 - ImportData......

Ok - hvad er problemet?

Fandt en "dummies" fejl i den private sub, så nu spiller det. (tror jeg) Næste problem er nede i Sub Importdata hvor jeg måske skal sætte en sti ind, ihvert fald melder den fejl i

    lin = "TEXT;" & [b]mappeSti[/B] & "\" & filnavn


Her er hele programmet pt.:

Option Explicit
Const drevSTi = "C:\Users\AndersVesterø\Desktop\Nordmark Hedensted\Tidsregistering\Data behandling\Maskiner\"        'JUSTERES
Const filID = "REG-FULD.A"                                          '-"-
Dim rækNr As Integer, filnavn As String, mapNavn
Sub traverserData()
    rækNr = 1
    traverserMappe drevSTi, rækNr
End Sub
Private Sub traverserMappe(mappenavn, rækNr)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn)
    Set fc = f.SubFolders
   
    For Each f1 In fc
        mapNavn = f1.Name
        findFiler f1.Path, f1.Name, rækNr
    Next
End Sub
Private Sub findFiler(mappeSti, mappe, rækNr)
Dim fs, f, f1, fc, fNavn As String, ext As String, navnSplit As Variant

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappeSti)
    Set fc = f.Files
   
    For Each f1 In fc
        filnavn = f1.Name
        If InStr(filnavn, filID) = 1 Then
            importData mappeSti, filnavn, rækNr
            rækNr = ActiveCell.SpecialCells(xlLastCell).Row + 1
        End If
    Next
End Sub
Sub importData()
'
' importDATA Makro
' Denne funktion indhenter data fra REG-FULD.A filer
'
Dim lin As String
    lin = "TEXT;" & mappeSti & "\" & filnavn
    startAdr = "$A$" & CStr(rækNr)

    Application.ScreenUpdating = False

    Sheets("Import").Select
   
    With ActiveSheet.QueryTables.Add(Connection:= _
        lin, Destination:=range(startAdr))
        .Name = "REG-FULD.A"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(9, 5, 1, 10)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    range("A1").Select
   
    Dim sidsteRække, række
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
   
    With ActiveSheet
    For række = sidsteRække To 1 Step -1
        If .cells(række, 1) = "" Then
            .Rows(række).EntireRow.Delete
        End If
    Next række
  End With
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
       
    MsgBox ("Data overført")
End Sub


Er jeg helt galt på den? eller begynder det er se lyst ud??

For Each f1 In fc
        filnavn = f1.Name
        If InStr(filnavn, filID) = 1 Then
            importData mappeSti, filnavn, rækNr '<-- her er kaldet
            rækNr = ActiveCell.SpecialCells(xlLastCell).Row + 1
        End If
    Next
End Sub
Sub importData()'<----- her mangler parametrene

Har afprøvet din koden med mine data efter rettelsen i #17 også en ændring af arknavn (import)  til (1).

Kører uden problemer.

Hej!

Jeg kan ikke afspille min makro hvis der står: Sub importData(mappeSti, mappe, rækNr) men hvis der ingen ting står i parentesen kan jeg fint afspille den, dog uden positivt resultat.

Hvad sker der i begge tilfælde du nævner?

Som sagt skal der være balance i kaldet af en Sub * og selve Sub'en **)

  For Each f1 In fc
        filnavn = f1.Name
        If InStr(filnavn, filID) = 1 Then
            importData mappeSti, filnavn, rækNr *)
            rækNr = ActiveCell.SpecialCells(xlLastCell).Row + 1
        End If
    Next
End Sub
Sub importData()    **)

Det er der ikke ovenfor

Hvis jeg forsøger at lave et RUN i den makro der hedder importData med tekst i parenteserne, vises SUBén ikke på listen over mulige at afspille. Hvis jeg fjerne teksten (mappeSti, mappe, rækNr) kan jeg afspille men får fejl.

Sub importData()

'
' importDATA Makro
' Denne funktion indhenter data fra REG-FULD.A filer
'
Dim lin As String
    lin = "TEXT;" & mappeSti & "\" & filnavn <-- mappesti fejl
    startAdr = "$A$" & CStr(rækNr)


Hvis jeg skriver:
Sub importData(mappeSti, mappe, rækNr)

'
' importDATA Makro
' Denne funktion indhenter data fra REG-FULD.A filer
'
Dim lin As String
    lin = "TEXT;" & mappeSti & "\" & filnavn
    startAdr = "$A$" & CStr(rækNr)

Vil denne Sub ikke afspilles. (Der er ikke mulighed for at spille den nogle steder... altså ingen fejl, men kan jo ikke lave et RUN på den!)

Ved ikke om det har noget at sige, men køre Excel 2013.

Med Alt+F8 skulle det kunne lade sig gøre at se **)

Option Explicit
Const drevSTi = "C:\Users\AndersVesterø\Desktop\Nordmark Hedensted\Tidsregistering\Data behandling\Maskiner\"        'JUSTERES
Const filID = "REG-FULD.A"                                          '-"-
Dim rækNr As Integer, filnavn As String, mapNavn
Sub traverserData()    '<------- det er her makroen begynder - **)

Okay, så er jeg mere med. For den eneste af de makroér jeg kan lave RUN på er også Sub TraverserData(). Nu for jeg fejl i :

Private Sub traverserMappe(mappenavn, rækNr)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn) <-- fs.GetFolder fejl
    Set fc = f.SubFolders
   
    For Each f1 In fc
        mapNavn = f1.Name
        findFiler f1.Path, f1.Name, rækNr
    Next
End Sub

Hvilken fejlmelding?
Hvis Debug - så aktiver denne knap og peg på "mappenavn" i Sub-hovedet for at se hvad der står?

Tjek, har rettet stien. Jeg tror det var dér fejlen lå.

Jeg har også en fejl hvor jeg tror at jeg mangler at definer en variable. Det er i Sub importData

Sub importData(mappeSti, mappe, rækNr)

'
' importDATA Makro
' Denne funktion indhenter data fra REG-FULD.A filer
'
Dim lin As String
    lin = "TEXT;" & mappeSti & "\" & filnavn
    startAdr = "$A$" & CStr(rækNr) <-- FEJL Variable not defined

    Application.ScreenUpdating = False

Har fået det til at virke ved at lave en DIM StartAdr as String og nu køre det!

Tusind tak for din gode tålmodighed... :-) Jeg laver en sammenfatning af importen på denne tråd så andre kan se det lidt mere sammenfattet resultat!

Fint - og selv tak & god ide..

Hej Supertekst...

Kunne godt bruge et indlæg fra dig i denne tråd! Bøvler med noget Loop som for mit Excel til at gå i "Svare ikke" mode...

http://www.eksperten.dk/spm/984442

Opsamling på denne makro!


Følgende har virket for mig, og jeg har tilføjet nogle kommentarer undervejs så det burde være nemt at rette til.


____________________________________________________________
Option Explicit
Const drevSTi = "C:\Nordmark - Hedensted\Nordmark Hedensted\Tidsregistering\Data behandling\Maskiner\"        'Sti til mappe der skal gennemses
Const filID = "REG-FULD.A"    'Filens navn
Dim rækNr As Integer, filnavn As String, mapNavn


Sub traverserData()
' Denne makro bliver kaldet for at begynde import
    rækNr = 1
    traverserMappe drevSTi, rækNr
End Sub

' <------
' De to efterfølgende Private sub´s skal ikke redigeres.
' ------>

Private Sub traverserMappe(mappenavn, rækNr)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn)
    Set fc = f.SubFolders
   
    For Each f1 In fc
        mapNavn = f1.Name
        findFiler f1.Path, f1.Name, rækNr
    Next
End Sub


Private Sub findFiler(mappeSti, mappe, rækNr)
Dim fs, f, f1, fc, fNavn As String, ext As String, navnSplit As Variant

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappeSti)
    Set fc = f.Files
   
    For Each f1 In fc
        filnavn = f1.Name
        If InStr(filnavn, filID) = 1 Then
            importData mappeSti, mappe, rækNr
           
           
            rækNr = ActiveCell.SpecialCells(xlLastCell).Row + 1
        End If
    Next
End Sub



Sub importData(mappeSti, mappe, rækNr)

'
' importDATA Makro
' Denne funktion indhenter data fra filer
'
Dim lin As String
Dim startAdr As String
    lin = "TEXT;" & mappeSti & "\" & filnavn
    startAdr = "$A$" & CStr(rækNr)

    Application.ScreenUpdating = False

    Sheets("Import").Select ' <-- Vælg hvilket ark der skal indsættes til

' 
' Efterfølgende import funktion har jeg "optaget" og derefter indsat her.
'

    With ActiveSheet.QueryTables.Add(Connection:= _
        lin, Destination:=range(startAdr))
        .Name = "REG-FULD.A"    '<--- rettes til efter fil navn
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(9, 5, 1, 10)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    range("A1").Select
   
    Dim sidsteRække, række
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
   
    With ActiveSheet
    For række = sidsteRække To 1 Step -1
        If .cells(række, 1) = "" Then
            .Rows(række).EntireRow.Delete
        End If
    Next række
  End With


' Flytter aktiv celle til først kommende tomme celle

    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select


' kontrol massagebox som kommer for hvergang en fil er impoteret
       
    MsgBox ("Data overført")
End Sub