---

Hi
Für meine Forschungsarbeit in Neuropsychologie muss ich etwa 3000 Datein von einer Analyse-Software ins Excel importieren, etwas einfaches umformatieren und abspeichern.
Ein wunderbarer Fall für ein Makro. Was eigentlich auch nicht so schwer wäre, wenn ich nur wüsste, wie ich im Makro eingeben kann, dass er immer im gleichen Folder das nächstfolgende File holen soll.

Also nochmals auf andere Art erklärt:

Mein Makro soll folgendes machen:

Excel öffnen, vom Folder X die Datei 1 holen, gemäss Anweisung umformatieren und dann ins Excel unter .xls abspeichern.
Dies habe ich mit Makro geschafft. Doch nun möchte ich ins Makro einbauen, dass er gleich wieder startet und nun aber Datei 2 holt und unter Datei2.xls abspeichert usw usw.

Kann mir jemand sagen, wie ich dies im VBE eingeben kann? Es ist ja nicht möglich mit *.xls zu arbeiten.

Danke vielmals für die Hilfe

Silvana

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi & willkommen Silvana,

hm Du schreibst leider nicht, was für Filetypes/-endung du hast.
Aber hier mal eine Schleife die zB alle xls-Files unter dem Pfad öffnet/schliesst:

Code:

---

Sub asdf()
  Dim f$, p$
  p = "D:\Cad\"
  f = Dir(p & "*.xls")
  Do While f <> ""
      Workbooks.Open p & f
      With ActiveWorkbook
        'machwas
        .Save
        .Close 0
      End With
      f = Dir
  Loop
End Sub

---

Gruss Nancy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

hier mal meine Lösung - ich habe es nur aus meiner bestehenden herauskopiert und ein wenig angepasst -

gruss Thomas

Code:

---

Public Sub Parts_umbennenen() 'hier werden erstmal nur die Dateien über Dateimanager vom User ausgewählt
    Dim NameZiel As Variant
      MsgBox "Hier ist der Menschh gefragt" & Chr$(13) & " Bitte gewünschten *.nc parts auswählen"
        ChDir "C:\LaufwerkE\TebisDaten" 'Pfadvorgeben
  NameZiel = Application.GetOpenFilename("NC-Dateien (*.nc),*.nc,", , "NC-Dateien für Dokumentation auswählen!", MultiSelect:=True) 'hier Endung anpassen - einlesen hier ascii-file
    If TypeName(NameZiel) = "Boolean" Then
        Beep
        MsgBox "min. eine Datei auswählen!"
        Exit Sub
    End If
    'zur weiteren verarbeitung NameZiel() verwenden
    umbenennen (NameZiel) 'hier der Aufruf an das einlese-umwandle-sichern-makro
End Sub

---

Code:

---

Sub umbenennen(Nums)
    For i = LBound(Nums) To UBound(Nums)
    'MsgBox "ausgewählte Dateien" & (Nums(i)) 'zur kontrolle
    Workbooks.OpenText Filename:= _
        (Nums(i)), Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
        TrailingMinusNumbers:=True
        'Windows((Nums(i))).Activate 'bei bedarf
        'hier mache was zb. munter formatieren/umbenennen- what ever
      Application.StatusBar = "Part" & Nums(i) & " geändert" 'hier rede ich ein wenig ;-)
  'nun weg zum Sichern
  Neuasxl$ = Mid(Nums(i), 1, (Len(Nums(i)) - 3)) & ".xls" '.nc weg .xls hinzu
  ActiveWorkbook.SaveAs Filename:=Neuasxl$, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
  ActiveWorkbook.Close savechanges:=True '
        Next i
End Sub

---

[Diese Nachricht wurde von Thomas Harmening am 15. Feb. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Nancy und Thomas

Danke viel, vielmals für Eure Angaben. Leider bin ich zuwenig geübt mit Makro, um diese wertvolle Infos auch verwerten zu können. Doch es ist mir ein Anliegen, dieses Makro zu schreiben, da sehr viele im Neuropsychologischen Institut dadurch x Stunden Zeit einsparen könnten.

Ich lege das Makro bei, auf welchem der Ablauf ersichtlich ist. So weit läuft es, was nun passieren muss, ist,

dass das nächste txt-file (vom Programm VisionAnalyzer) vom angegeben Pfad geholt werden muss und dann wieder unter dem gleichen Namen, jedoch nun mit xls-Endung in einem anderen Folder gespeichert werden soll.

Bsp: 1. Datei: VP0007_Filled_BOW_Filled_Check12.5_A.txt  öffnen - bearbeiten - abspeichern in anderen Folder unter VP0007_Filled_BOW_Filled_Check12.5_A.xls
Dann kommt die nächste Datei:
VP0007_Filled_BOW_Filled_Check50_A.txt - öffnen - bearbeiten und speichern unter VP0007_Filled_BOW_Filled_Check12.5_A.xls

Hier das erstellte Makro mit den Bearbeitungsschritten:

Sub VisionAnalyzer_to_Excel()
'
' VisionAnalyzer_to_Excel Macro
' Macro recorded 16.02.2006 by
'
' Keyboard Shortcut: Ctrl+s
'
    Workbooks.OpenText Filename:= _
        "D:\STUDIES\EEG\Healthy_Volunteers\Luminance_Contrast\Silvana\Export\VP0007_Filled_BOW_Filled_Check12.5_A.txt" _
        , Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _
        Comma:=False, Space:=True, 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), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
        Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array( _
        28, 1), Array(29, 1), Array(30, 1)), TrailingMinusNumbers:=True
    Cells.Select
    Selection.NumberFormat = "0.00"
    Selection.ColumnWidth = 5.29
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Fp1"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Fp2"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "F7"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "F3"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Fz"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "F4"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "F8"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "FT7"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "FC3"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "FC4"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "FT8"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "T7"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "C3"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "Cz"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "C4"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "T8"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "TP7"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "CP3"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "CPz"
    Range("T1").Select
    ActiveCell.FormulaR1C1 = "CP4"
    Range("U1").Select
    ActiveCell.FormulaR1C1 = "TP8"
    Range("V1").Select
    ActiveCell.FormulaR1C1 = "P7"
    Range("W1").Select
    ActiveCell.FormulaR1C1 = "P3"
    Range("X1").Select
    ActiveCell.FormulaR1C1 = "Pz"
    Range("Y1").Select
    ActiveCell.FormulaR1C1 = "P4"
    Range("Z1").Select
    ActiveCell.FormulaR1C1 = "P8"
    Range("AA1").Select
    ActiveCell.FormulaR1C1 = "O1"
    Range("AB1").Select
    ActiveCell.FormulaR1C1 = "Oz"
    Range("AC1").Select
    ActiveCell.FormulaR1C1 = "O2"
    Range("AD1").Select
    ActiveCell.FormulaR1C1 = "FCz"
    Rows("1:1").Select
    Selection.Font.Bold = True
    ChDir "D:\STUDIES\EEG\Healthy_Volunteers\Luminance_Contrast\Silvana\XLS"
    ActiveWorkbook.SaveAs Filename:= _
        "D:\STUDIES\EEG\Healthy_Volunteers\Luminance_Contrast\Silvana\XLS\VP0007_Filled_BOW_Filled_Check12.5_A.xls" _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
End Sub

Ach, es wäre so toll, wenn Du Nancy oder Du Thomas mir die richtige Programmierung ins Makro einschreiben könntet.

Danka vilmol
Silvana

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

nicht besonders getestet,

Gruss Nancy
--

Code:

---

Sub asdf()
    Dim header
    Dim f$, sourceP$, targetP$
    sourceP = "d:\": targetP = "D:\Cad\"
    header = Array("Fp1", "Fp2", "F7", "F3", "Fz", "F4", "F8", "FT7", "FC3", "FC4", "FT8", "T7", _
    "C3", "Cz", "C4", "T8", "TP7", "CP3", "CPz", "CP4", "TP8", "P7", "P3", "Pz", "P4", "P8", "O1", _
    "Oz", "O2", "FCz")
    f = Dir(sourceP & "*.txt")
    Do While f <> ""
        Workbooks.Open Filename:=sourceP & f
        Rows(1).Insert
        With Range("A1:AD1")
            .ColumnWidth = 5.29
            .Value = header
            .Font.Bold = True
        End With
        ActiveWorkbook.SaveAs targetP & Left(f, Len(f) - 3) & "xls", xlNormal
        ActiveWindow.Close
        f = Dir
    Loop
End Sub

---

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP