Excel zu Text für mehrere Dateien

Dieses Thema Excel zu Text für mehrere Dateien im Forum "Microsoft Office Suite" wurde erstellt von kukris, 2. Juni 2006.

Thema: Excel zu Text für mehrere Dateien Hallo, ich möchte mehrere Excel-Dateien auf einmal zu Textdateien (txt) konvertieren. Gibt dafür irgendeine...

  1. Hallo,

    ich möchte mehrere Excel-Dateien auf einmal zu Textdateien (txt) konvertieren. Gibt dafür irgendeine Software / Addin / Script?
    Wenn möglich Freeware.
     
  2. Hallo kukris,

    mit einem Makro liesse sich das wahrscheinlich alles regeln.

    txt soll heissen als txt-Datei und Werte durch Tabulator getrennt oder soll ein anderes Trennzeichen verwendet werden ?

    Haben die Mappen denn alle nur ein Blatt ?

    Sind die Dateien alle in einem Verzeichnis ? (plus Unterverzeichnisse)

    Gruß Matjes :)
     
  3. Hallo Matjes,

    - Trennzeichen sollen Tabulatoren sein
    - Die Mappen haben meistens nur ein Blatt, notfalls muss ich sie eben einzeln abspeichern
    - Die Dateien liegen in einem Verzeichnis ohne Unterverzeichnisse
     
  4. Hallo kukris,

    dann probier mal den folgenden Makro aus. Der kann auch Arbeitsmappen mit mehreren Blättern. Jedes Blatt wird dann unter Dateinamen_Blattname.txt gespeichert. Einbeziehung der Unterverzeichnisse kannst du auswählen.

    Packe diesen Makro in eine eigene Datei. Der Name sollte so gewählt sein, daß er sich von allen Namen zu konvertierender Dateien unterscheidet, da der Makro ausschließt, daß eine Datei gleichen Namens konvertiert wird.

    Gruß Matjes :)
    Code:
    Option Explicit
    ' Typdeklaration für API-Dialog->Verzeichnis auswählen'
    Private Type BrowseInfo
        hOwner          As Long
        pidlRoot        As Long
        pszDisplayName  As String
        lpszTitle       As String
        ulFlags         As Long
        lpfn            As Long
        lParam          As Long
        iImage          As Long
    End Type
    
    Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
    
    Sub main_XLSAlsTXTTabSepariertSpeichern()
     ->Konvertiert *.xls zu *.txt, Tab separiert
     ->
     ->Pfad-Auswahl für zu konvertierende Arbeitsmappen
     ->Auswahl->Unterverzeichnisse einbeziehen'
     ->
     ->Speichert die xls-Datei als Tabsparierte txt-Datei ab.
     ->Speicherort:   Pfad der xls-Datei
     ->Überschreiben: ggf.vorhandene txt-Datei gleichen Namens wird überschrieben
     ->
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, nur mit Endung txt
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, aber um Namen des jeweiligen Arbeitsblattes erweitert
     ->               ,Endung txt
     ->
     ->Dateien mit gleichem Namen wie die makro-Datei werden von der Konvertierung ausgeschlossen
      
      
      Dim i As Long, ret As Integer, sDateiname As String
      Dim sPfad As String, sDateinameFull As String, bSubFolders As Boolean
      
     ->Pruefen, ob nur diese Mappe geöffnet ist
      If Application.Workbooks.Count <> 1 Then
        MsgBox _
          Bitte schliessen sie alle Mappen, bis auf die Mappe mit dem Makro & _
          vbLf & ThisWorkbook.Name
        Exit Sub
      End If
      
     ->Wurzelverzeichnis abfragen
      sPfad = VerzeichnisWaehlen(Verzeichnis der zu konvertierenden Arbeitsmappen auswählen)
      If sPfad =  Then Exit Sub-> Abbruch ?
      
     ->Abfrage mit/ohne Sub-Directories
      ret = MsgBox( _
        Sollen die Unterverzeichnisse einbezogen werden?, _
        vbYesNoCancel + vbDefaultButton2 + vbQuestion, _
        Auswahl mit/ohne Unterverzeichnisse)
      If ret = vbYes Then
        bSubFolders = True
      ElseIf ret = vbNo Then
        bSubFolders = False
      Else
        Exit Sub->Abbruch
      End If
    
      Application.ScreenUpdating = False
      
     ->Files suchen und konvertieren
      With Application.FileSearch
        .NewSearch
        .LookIn = sPfad
        .SearchSubFolders = bSubFolders
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
       ->alle gefundenen files
        For i = 1 To .FoundFiles.Count
          sDateinameFull = .FoundFiles(i)
          sDateiname = DateinameAusDateinameFull(sDateinameFull)
         ->Datei gleichen Namens wie die Makro-Datei von Konvertierung ausschliessen
          If LCase(ThisWorkbook.Name) <> LCase(sDateiname) Then
            Application.StatusBar = sDateinameFull
           ->File konvertieren
            If Not EineDateiXLSAlsTXTTabSepariertSpeichern(sDateinameFull) Then
              MsgBox Fehler bei Konvertierung. & vbLf & sDateinameFull
            End If
            Application.StatusBar = 
            DoEvents
          End If
        Next
      End With
      
      Application.ScreenUpdating = True
    End Sub
    '**********************************************************************************
    Private Function EineDateiXLSAlsTXTTabSepariertSpeichern(sDateinameFull As String)
    '**********************************************************************************
     ->Speichert die xls-Datei als Tabsparierte txt-Datei ab.
     ->Speicherort:   Pfad der xls-Datei
     ->Überschreiben: ggf.vorhandene txt-Datei gleichen Namens wird überschrieben
      
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, nur mit Endung txt
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, aber um Namen des jeweiligen Arbeitsblattes erweitert
     ->               ,Endung txt
      
      Dim wb As Workbook
    
      EineDateiXLSAlsTXTTabSepariertSpeichern = False
      
     ->Datei-Endung prüfen
      If LCase(Right(sDateinameFull, 4)) = .xls Then
       ->prüfen, ob Datei existiert
        If Dir(sDateinameFull, vbNormal) <>  Then
          If DateiOeffnen(sDateinameFull, wb) Then
           ->Mappenschutz entfernen
            If MappenschutzEntfernen(wb) Then
             ->Blattschutz entfernen
              If BlattschutzEntfernen(wb) Then
               ->Blaetter bearbeiten
                If Not BlaetterBearbeiten(wb) Then
                  MsgBox Blatt/Blätter konnten nicht gespeichert werden. & vbLf & wb.FullName
                Else
                  EineDateiXLSAlsTXTTabSepariertSpeichern = True
                End If
              Else
                MsgBox Blattschutz läßt sich nicht entfernen. & vbLf & wb.FullName
              End If
            Else
              MsgBox Mappenschutz läßt sich nicht entfernen. & vbLf & wb.FullName
            End If
            wb.Close savechanges:=False
          Else
            MsgBox Datei kann nicht geöffnet werden. & vbLf & sDateinameFull
          End If
        Else
          MsgBox Datei nicht vorhanden. & vbLf & sDateinameFull: GoTo AUFRAEUMEN
        End If
      Else
        MsgBox Datei-Endung <> .xls . & vbLf & sDateinameFull: GoTo AUFRAEUMEN
      End If
    AUFRAEUMEN:
      Set wb = Nothing
    End Function
    '**********************************************************************************
    Private Function BlaetterBearbeiten(wb As Workbook) As Boolean
    '**********************************************************************************
     ->Voraussetzung: kein Mappenschutz
     ->Voraussetzung: kein Blattschutz
    
      Dim ws As Worksheet
      Dim sDateiname As String, sPfad As String, sDateinameFull As String
      Dim BN() As String, BNCnt As Long, sDateinameFulltmp As String
      Dim x As Long
      
      BNCnt = 0: ReDim BN(1 To 1)
      
      BlaetterBearbeiten = False
      
     ->Pfad und Dateiname der Ursprungsdatei
      sDateiname = wb.Name: sPfad = wb.Path: sDateinameFull = wb.FullName
      
     ->Arbeitsblattnamen feststellen
      For Each ws In wb.Worksheets
        If ws.Type = xlWorksheet Then
          BNCnt = BNCnt + 1: ReDim Preserve BN(1 To BNCnt): BN(BNCnt) = ws.Name
        End If
      Next
      
      If BNCnt < 1 Then
        MsgBox Kein Arbeitsblatt enthalten. & vbLf & wb.FullName
      ElseIf BNCnt = 1 Then
       ->Mappe mit einem Arbeitsblatt
        Application.DisplayAlerts = False
        wb.SaveAs _
          FileName:=Left(sDateinameFull, Len(sDateinameFull) - 4) & .txt, _
          FileFormat:=xlText
        Application.DisplayAlerts = True
        BlaetterBearbeiten = True
      Else
       ->Mappe mit mehreren Blättern
        
       ->Über alle Arbeitsblätter
        For x = 1 To BNCnt
         ->Namen um Blattnamen erweitern
          sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & _ & BN(x) & .txt
         ->alle Blätter bis auf das betreffende entfernen
          Application.DisplayAlerts = False
          For Each ws In wb.Worksheets
            If ws.Name <> BN(x) Then ws.Delete
          Next
          wb.SaveAs FileName:=sDateinameFulltmp, FileFormat:=xlText
          wb.Close savechanges:=False
          Application.DisplayAlerts = True
          
          Call DateiOeffnen(sDateinameFull, wb)->Ursprungs-Datei wieder öffnen
          Call MappenschutzEntfernen(wb)       ->Mappenschutz entfernen
          Call BlattschutzEntfernen(wb)         'Blattschutz entfernen
          DoEvents
        Next
        BlaetterBearbeiten = True
      End If
    AUFRAEUMEN:
      Set ws = Nothing
    End Function
    '**********************************************************************************
    Private Function DateiOeffnen(sDateinameFull As String, wb As Workbook)
    '**********************************************************************************
      DateiOeffnen = True
    
      On Error Resume Next
      Application.DisplayAlerts = False
     ->wichtig UpdateLinks=0, bedeutet keine Aktuallisierung von Bezügen
      Set wb = Workbooks.Open(FileName:=sDateinameFull, _
                              UpdateLinks:=0, _
                              ReadOnly:=False, _
                              Password:=, _
                              WriteResPassword:=, _
                              IgnoreReadOnlyRecommended:=True, _
                              AddToMru:=False)
      Application.DisplayAlerts = True
      If Err.Number <> 0 Then Err.Clear: DateiOeffnen = False
      On Error GoTo 0
    End Function
    '**********************************************************************************
    Private Function MappenschutzEntfernen(wb As Workbook) As Boolean
    '**********************************************************************************
      
      Dim b_ProtectWindows As Boolean, b_ProtectStructure As Boolean
      
      MappenschutzEntfernen = True
      
      b_ProtectWindows = wb.ProtectWindows
      b_ProtectStructure = wb.ProtectStructure
      
      If b_ProtectWindows Or b_ProtectStructure Then
        On Error Resume Next
        Application.DisplayAlerts = False
       ->Testen, ob sich der Mappenschutz entfernen läßt
        wb.Unprotect Password:=
        Application.DisplayAlerts = True
        If Err.Number <> 0 Then
          Err.Clear: On Error GoTo 0
          MappenschutzEntfernen = False
        End If
      End If
    End Function
    '**********************************************************************************
    Private Function BlattschutzEntfernen(wb As Workbook) As Boolean
    '**********************************************************************************
      
      Dim ws As Worksheet
      Dim b_ProtectContents As Boolean, b_ProtectDrawingObjects As Boolean, b_ProtectScenarios As Boolean
      Dim b_ProtectUserInterfaceOnly As Boolean->Schutz für Makros
      
      BlattschutzEntfernen = True
      
      For Each ws In wb.Worksheets
        b_ProtectContents = ws.ProtectContents
        b_ProtectDrawingObjects = ws.ProtectDrawingObjects
        b_ProtectScenarios = ws.ProtectScenarios
        b_ProtectUserInterfaceOnly = ws.ProtectionMode
        
        If b_ProtectContents Or b_ProtectDrawingObjects Or b_ProtectScenarios Or _
           b_ProtectUserInterfaceOnly Then
          
          On Error Resume Next
          Application.DisplayAlerts = False
         ->Testen, ob sich der Blattschutz entfernen läßt
          ws.Unprotect Password:=
          Application.DisplayAlerts = True
          If Err.Number <> 0 Then
            Err.Clear: On Error GoTo 0
            BlattschutzEntfernen = False
            GoTo AUFRAEUMEN
          End If
        End If
      Next
    AUFRAEUMEN:
      Set ws = Nothing
    End Function
    '***********************************************************
    Private Function VerzeichnisWaehlen(Optional DialogTitel) As String
    '***********************************************************
    ' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
        Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
        Dim hWndAccessApp As Long
      
        With StrukturVerzeichnisInfo
            .hOwner = hWndAccessApp
            .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
            .ulFlags = &H1-> BIF_RETURNONLYFSDIRS
        End With
        
        ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
        Pfad = Space$(512)
        
        If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWaehlen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
        
    End Function
    '***********************************************************
    Private Function DateinameAusDateinameFull(sDateinameFull As String) As String
    '***********************************************************
      Dim pos As Long, posx As Long
      pos = 0: posx = 0
      Do
        pos = InStr(pos + 1, sDateinameFull, Application.PathSeparator)
        If pos > 0 Then posx = pos
      Loop While pos <> 0
      If posx = 0 Then
        DateinameAusDateinameFull = sDateinameFull
      Else
        DateinameAusDateinameFull = Right(sDateinameFull, Len(sDateinameFull) - posx)
      End If
      
    End Function
     
  5. Hallo Matjes,

    vielen Dank für dein Makro. Das ist echt Klasse. Wenn das Makro jetzt noch überflüssige Leerzeichen und Tabs nach Zeilenende (Nicht alle Zeilen sind gleich lang) entfernen könnte, wäre ich überglücklich. Ich bin leider eine Niete in Visual Basic und habe es nicht hinbekommen. Ich wollte dazu folgenden Code benutzen, aber wusste nicht wie ich es in dein Makro einbinden soll. Für weitere Hilfe wäre ich echt dankbar.

    [pre]
    If sInputDateiname <> Then
      Open sInputDateiname For Output As #sOutputDateiname
      Set Rng = ActiveCell.CurrentRegion
      Debug.Print Rng.Address
      FCol = Rng.Columns(1).Column
      LCol = Rng.Columns(Rng.Columns.Count).Column
      Frow = Rng.Rows(1).Row
      Lrow = Rng.Rows(Rng.Rows.Count).Row
      For i = Frow To Lrow
       outputLine =
       For j = FCol To LCol
         value = Replace(Trim(Cells(i, j)), , ?)
         If Val(value) = value Then
            value = Round(value, 3)
         End If
         outputLine = outputLine & & value & &
       Next j
       
        outputLine = Trim(outputLine)
       outputLine = Replace(outputLine, , Chr(9))
       outputLine = Replace(outputLine, ?, )
             
       Print #sOutputDateiname, outputLine
      Next i
    Close #sOutputDateiname
    End If
    [/pre]
     
  6. Hallo kurkis,

    ich hab dir das mal eingebaut als->BlaetterBearbeiten2'. Die Änderung ist sozusagen eine eigene txt-Export-Funktion  :D

    Die alte Funktion ist immernoch enthalten. Zum Umschalten dient die Konstante SCHALTER_EIGENESCHRIEBROUTINE. Sie ist jetzt auf->BlaetterBearbeiten2' eingestellt.

    In->BlaetterBearbeiten2' wird deine Schreibroutine TextdateiSchreiben statt dem normalen SaveAs txt-Datei aufgerufen.

    In TextdateiSchreiben werden die Funktionen Round() und Replace() aufgerufen. Diese sind jedoch erst ab Excel2000 verfügbar. Damit es auch unter Excel97 funktioniert hab ich eigene Routinen hinzugefügt.

    Bei Round() als Standard-Funktion ist auch zu beachten, dass sie nicht kaufmännisch rundet. Die hinzugefügte Funktion arbeitet dagegen mit kaufmännischem Runden.

    Die Val()-Funktion hab ich sinnvoll ersetzt. Das Runden auf 3 Stellen findet statt, wenn der zu schreibende Wert dem double-Format entspricht. Mußt mal schauen, ob das deinen Wünschen entspricht.

    Gruß Matjes :)
    Code:
    Option Explicit
    ' Typdeklaration für API-Dialog->Verzeichnis auswählen'
    Private Type BrowseInfo
        hOwner          As Long
        pidlRoot        As Long
        pszDisplayName  As String
        lpszTitle       As String
        ulFlags         As Long
        lpfn            As Long
        lParam          As Long
        iImage          As Long
    End Type
    
    Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
    
    'Schalter
    ' False: Output erfolgt als normale Excel-txt-Datei
    ' True : Output erfolgt mit eigener Schreibroutine als txt-Datei
    Private Const SCHALTER_EIGENESCHRIEBROUTINE As Boolean = True
    
    Sub main_XLSAlsTXTTabSepariertSpeichern()
     ->Konvertiert *.xls zu *.txt, Tab separiert
     ->
     ->Pfad-Auswahl für zu konvertierende Arbeitsmappen
     ->Auswahl->Unterverzeichnisse einbeziehen'
     ->
     ->Speichert die xls-Datei als Tabsparierte txt-Datei ab.
     ->Speicherort:   Pfad der xls-Datei
     ->Überschreiben: ggf.vorhandene txt-Datei gleichen Namens wird überschrieben
     ->
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, nur mit Endung txt
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, aber um Namen des jeweiligen Arbeitsblattes erweitert
     ->               ,Endung txt
     ->
     ->Dateien mit gleichem Namen wie die makro-Datei werden von der Konvertierung ausgeschlossen
      
      
      Dim i As Long, ret As Integer, sDateiname As String
      Dim sPfad As String, sDateinameFull As String, bSubFolders As Boolean
      
     ->Pruefen, ob nur diese Mappe geöffnet ist
      If Application.Workbooks.Count <> 1 Then
        MsgBox _
          Bitte schliessen sie alle Mappen, bis auf die Mappe mit dem Makro & _
          vbLf & ThisWorkbook.Name
        Exit Sub
      End If
      
     ->Wurzelverzeichnis abfragen
      sPfad = VerzeichnisWaehlen(Verzeichnis der zu konvertierenden Arbeitsmappen auswählen)
      If sPfad =  Then Exit Sub-> Abbruch ?
      
     ->Abfrage mit/ohne Sub-Directories
      ret = MsgBox( _
        Sollen die Unterverzeichnisse einbezogen werden?, _
        vbYesNoCancel + vbDefaultButton2 + vbQuestion, _
        Auswahl mit/ohne Unterverzeichnisse)
      If ret = vbYes Then
        bSubFolders = True
      ElseIf ret = vbNo Then
        bSubFolders = False
      Else
        Exit Sub->Abbruch
      End If
    
      Application.ScreenUpdating = False
      
     ->Files suchen und konvertieren
      With Application.FileSearch
        .NewSearch
        .LookIn = sPfad
        .SearchSubFolders = bSubFolders
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
       ->alle gefundenen files
        For i = 1 To .FoundFiles.Count
          sDateinameFull = .FoundFiles(i)
          sDateiname = DateinameAusDateinameFull(sDateinameFull)
         ->Datei gleichen Namens wie die Makro-Datei von Konvertierung ausschliessen
          If LCase(ThisWorkbook.Name) <> LCase(sDateiname) Then
            Application.StatusBar = sDateinameFull
           ->File konvertieren
            If Not EineDateiXLSAlsTXTTabSepariertSpeichern(sDateinameFull) Then
              MsgBox Fehler bei Konvertierung. & vbLf & sDateinameFull
            End If
            Application.StatusBar = 
            DoEvents
          End If
        Next
      End With
      
      Application.ScreenUpdating = True
    End Sub
    '**********************************************************************************
    Private Function EineDateiXLSAlsTXTTabSepariertSpeichern(sDateinameFull As String)
    '**********************************************************************************
     ->Speichert die xls-Datei als Tabsparierte txt-Datei ab.
     ->Speicherort:   Pfad der xls-Datei
     ->Überschreiben: ggf.vorhandene txt-Datei gleichen Namens wird überschrieben
      
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, nur mit Endung txt
     ->Mappen mit einem Arbeitsblatt
     ->Name:          wie xls-Datei, aber um Namen des jeweiligen Arbeitsblattes erweitert
     ->               ,Endung txt
      
      Dim wb As Workbook
    
      EineDateiXLSAlsTXTTabSepariertSpeichern = False
      
     ->Datei-Endung prüfen
      If LCase(Right(sDateinameFull, 4)) = .xls Then
       ->prüfen, ob Datei existiert
        If Dir(sDateinameFull, vbNormal) <>  Then
          If DateiOeffnen(sDateinameFull, wb) Then
           ->Mappenschutz entfernen
            If MappenschutzEntfernen(wb) Then
             ->Blattschutz entfernen
              If BlattschutzEntfernen(wb) Then
               ->Blaetter bearbeiten
                If SCHALTER_EIGENESCHRIEBROUTINE Then
                 ->eigene Schreibroutine wird benutzt
                  If Not BlaetterBearbeiten2(wb) Then
                    MsgBox Blatt/Blätter konnten nicht gespeichert werden. & vbLf & wb.FullName
                  Else
                    EineDateiXLSAlsTXTTabSepariertSpeichern = True
                  End If
                Else
                 ->normale Excel-Txt-Datei schreiben
                  If Not BlaetterBearbeiten(wb) Then
                    MsgBox Blatt/Blätter konnten nicht gespeichert werden. & vbLf & wb.FullName
                  Else
                    EineDateiXLSAlsTXTTabSepariertSpeichern = True
                  End If
                End If
              Else
                MsgBox Blattschutz läßt sich nicht entfernen. & vbLf & wb.FullName
              End If
            Else
              MsgBox Mappenschutz läßt sich nicht entfernen. & vbLf & wb.FullName
            End If
            wb.Close savechanges:=False
          Else
            MsgBox Datei kann nicht geöffnet werden. & vbLf & sDateinameFull
          End If
        Else
          MsgBox Datei nicht vorhanden. & vbLf & sDateinameFull: GoTo AUFRAEUMEN
        End If
      Else
        MsgBox Datei-Endung <> .xls . & vbLf & sDateinameFull: GoTo AUFRAEUMEN
      End If
    AUFRAEUMEN:
      Set wb = Nothing
    End Function
    '**********************************************************************************
    Private Function BlaetterBearbeiten(wb As Workbook) As Boolean
    '**********************************************************************************
     ->Voraussetzung: kein Mappenschutz
     ->Voraussetzung: kein Blattschutz
    
      Dim ws As Worksheet
      Dim sDateiname As String, sPfad As String, sDateinameFull As String
      Dim BN() As String, BNCnt As Long, sDateinameFulltmp As String
      Dim x As Long
      
      BNCnt = 0: ReDim BN(1 To 1)
      
      BlaetterBearbeiten = False
      
     ->Pfad und Dateiname der Ursprungsdatei
      sDateiname = wb.Name: sPfad = wb.Path: sDateinameFull = wb.FullName
      
     ->Arbeitsblattnamen feststellen
      For Each ws In wb.Worksheets
        If ws.Type = xlWorksheet Then
          BNCnt = BNCnt + 1: ReDim Preserve BN(1 To BNCnt): BN(BNCnt) = ws.Name
        End If
      Next
      
      If BNCnt < 1 Then
        MsgBox Kein Arbeitsblatt enthalten. & vbLf & wb.FullName
      ElseIf BNCnt = 1 Then
       ->Mappe mit einem Arbeitsblatt
        Application.DisplayAlerts = False
        wb.SaveAs _
          FileName:=Left(sDateinameFull, Len(sDateinameFull) - 4) & .txt, _
          FileFormat:=xlText
        Application.DisplayAlerts = True
        BlaetterBearbeiten = True
      Else
       ->Mappe mit mehreren Blättern
        
       ->Über alle Arbeitsblätter
        For x = 1 To BNCnt
         ->Namen um Blattnamen erweitern
          sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & _ & BN(x) & .txt
         ->alle Blätter bis auf das betreffende entfernen
          Application.DisplayAlerts = False
          For Each ws In wb.Worksheets
            If ws.Name <> BN(x) Then ws.Delete
          Next
          wb.SaveAs FileName:=sDateinameFulltmp, FileFormat:=xlText
          wb.Close savechanges:=False
          Application.DisplayAlerts = True
          
          Call DateiOeffnen(sDateinameFull, wb)->Ursprungs-Datei wieder öffnen
          Call MappenschutzEntfernen(wb)       ->Mappenschutz entfernen
          Call BlattschutzEntfernen(wb)         'Blattschutz entfernen
          DoEvents
        Next
        BlaetterBearbeiten = True
      End If
    AUFRAEUMEN:
      Set ws = Nothing
    End Function
    '**********************************************************************************
    Private Function DateiOeffnen(sDateinameFull As String, wb As Workbook)
    '**********************************************************************************
      DateiOeffnen = True
    
      On Error Resume Next
      Application.DisplayAlerts = False
     ->wichtig UpdateLinks=0, bedeutet keine Aktuallisierung von Bezügen
      Set wb = Workbooks.Open(FileName:=sDateinameFull, _
                              UpdateLinks:=0, _
                              ReadOnly:=False, _
                              Password:=, _
                              WriteResPassword:=, _
                              IgnoreReadOnlyRecommended:=True, _
                              AddToMru:=False)
      Application.DisplayAlerts = True
      If Err.Number <> 0 Then Err.Clear: DateiOeffnen = False
      On Error GoTo 0
    End Function
    '**********************************************************************************
    Private Function MappenschutzEntfernen(wb As Workbook) As Boolean
    '**********************************************************************************
      
      Dim b_ProtectWindows As Boolean, b_ProtectStructure As Boolean
      
      MappenschutzEntfernen = True
      
      b_ProtectWindows = wb.ProtectWindows
      b_ProtectStructure = wb.ProtectStructure
      
      If b_ProtectWindows Or b_ProtectStructure Then
        On Error Resume Next
        Application.DisplayAlerts = False
       ->Testen, ob sich der Mappenschutz entfernen läßt
        wb.Unprotect Password:=
        Application.DisplayAlerts = True
        If Err.Number <> 0 Then
          Err.Clear: On Error GoTo 0
          MappenschutzEntfernen = False
        End If
      End If
    End Function
    '**********************************************************************************
    Private Function BlattschutzEntfernen(wb As Workbook) As Boolean
    '**********************************************************************************
      
      Dim ws As Worksheet
      Dim b_ProtectContents As Boolean, b_ProtectDrawingObjects As Boolean, b_ProtectScenarios As Boolean
      Dim b_ProtectUserInterfaceOnly As Boolean->Schutz für Makros
      
      BlattschutzEntfernen = True
      
      For Each ws In wb.Worksheets
        b_ProtectContents = ws.ProtectContents
        b_ProtectDrawingObjects = ws.ProtectDrawingObjects
        b_ProtectScenarios = ws.ProtectScenarios
        b_ProtectUserInterfaceOnly = ws.ProtectionMode
        
        If b_ProtectContents Or b_ProtectDrawingObjects Or b_ProtectScenarios Or _
           b_ProtectUserInterfaceOnly Then
          
          On Error Resume Next
          Application.DisplayAlerts = False
         ->Testen, ob sich der Blattschutz entfernen läßt
          ws.Unprotect Password:=
          Application.DisplayAlerts = True
          If Err.Number <> 0 Then
            Err.Clear: On Error GoTo 0
            BlattschutzEntfernen = False
            GoTo AUFRAEUMEN
          End If
        End If
      Next
    AUFRAEUMEN:
      Set ws = Nothing
    End Function
    '***********************************************************
    Private Function VerzeichnisWaehlen(Optional DialogTitel) As String
    '***********************************************************
    ' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
        Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
        Dim hWndAccessApp As Long
      
        With StrukturVerzeichnisInfo
            .hOwner = hWndAccessApp
            .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
            .ulFlags = &H1-> BIF_RETURNONLYFSDIRS
        End With
        
        ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
        Pfad = Space$(512)
        
        If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWaehlen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
        
    End Function
    '***********************************************************
    Private Function DateinameAusDateinameFull(sDateinameFull As String) As String
    '***********************************************************
      Dim pos As Long, posx As Long
      pos = 0: posx = 0
      Do
        pos = InStr(pos + 1, sDateinameFull, Application.PathSeparator)
        If pos > 0 Then posx = pos
      Loop While pos <> 0
      If posx = 0 Then
        DateinameAusDateinameFull = sDateinameFull
      Else
        DateinameAusDateinameFull = Right(sDateinameFull, Len(sDateinameFull) - posx)
      End If
      
    End Function
    
    '**********************************************************************************
    Private Function BlaetterBearbeiten2(wb As Workbook) As Boolean
    '**********************************************************************************
     ->Voraussetzung: kein Mappenschutz
     ->Voraussetzung: kein Blattschutz
    
      Dim ws As Worksheet
      Dim sDateiname As String, sPfad As String, sDateinameFull As String
      Dim BN() As String, BNCnt As Long, sDateinameFulltmp As String
      Dim x As Long
      
      BNCnt = 0: ReDim BN(1 To 1)
      
      BlaetterBearbeiten2 = False
      
     ->Pfad und Dateiname der Ursprungsdatei
      sDateiname = wb.Name: sPfad = wb.Path: sDateinameFull = wb.FullName
      
     ->Arbeitsblattnamen feststellen
      For Each ws In wb.Worksheets
        If ws.Type = xlWorksheet Then
          BNCnt = BNCnt + 1: ReDim Preserve BN(1 To BNCnt): BN(BNCnt) = ws.Name
        End If
      Next
      
      If BNCnt < 1 Then
        MsgBox Kein Arbeitsblatt enthalten. & vbLf & wb.FullName
      ElseIf BNCnt = 1 Then
       ->Mappe mit einem Arbeitsblatt
        sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & .txt
        Call TextdateiSchreiben(wb.Worksheets(BN(1)), sDateinameFulltmp)
        
        BlaetterBearbeiten2 = True
      Else
       ->Mappe mit mehreren Blättern
        
       ->Über alle Arbeitsblätter
        For x = 1 To BNCnt
         ->Namen um Blattnamen erweitern
          sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & _ & BN(x) & .txt
          Call TextdateiSchreiben(wb.Worksheets(BN(x)), sDateinameFulltmp)
          DoEvents
        Next
        BlaetterBearbeiten2 = True
      End If
    AUFRAEUMEN:
      Set ws = Nothing
    End Function
    '**********************************************************************************
    Function TextdateiSchreiben(ws As Worksheet, sInputDateiname As String)
    
      Dim DateiHandle As Integer
      Dim Rng As Range
      Dim Fcol As Long, Lcol As Long, Frow As Long, LRow As Long
      Dim i As Long, j As Long, s As String, s2 As String
      Dim outputLine As String
      
      If sInputDateiname <>  Then
        DateiHandle = FreeFile
        Open sInputDateiname For Output As #DateiHandle
        Set Rng = ws.UsedRange
        Fcol = Rng.Column
        Lcol = Rng.Column + Rng.Columns.Count - 1
        Frow = Rng.Row
        LRow = Rng.Row + Rng.Rows.Count - 1
        For i = Frow To LRow
          outputLine = 
          For j = Fcol To Lcol
            s = Replace(Trim(ws.Cells(i, j)),  , ?)
            On Error Resume Next
            s2 = CDbl(s)
            If Err.Number <> 0 Then
              Err.Clear
            Else
              s = CStr(Round(CDbl(s), 3))
            End If
            On Error GoTo 0
            outputLine = outputLine &  & s &  &  
          Next j
          outputLine = Trim(outputLine)
          outputLine = Replace(outputLine,  , Chr(9))
          outputLine = Replace(outputLine, ?,  )
         -><<< Hier könnte man noch Leerzeilen abfragen <<<
          Print #DateiHandle, outputLine
        Next i
        Close #DateiHandle
      End If
    AUFRAEUMEN:
      Set Rng = Nothing
    End Function
    '**********************************************************************************
    'Funktion erst ab Excel 2000 vorhanden, daher Ersatzfunktion für EXCEL97
    Private Function Round(ByVal dZahl As Double, ByVal AnzNachkommastellen As Integer) As Double
      Round = Int(dZahl * 10 ^ AnzNachkommastellen + 0.5) / 10 ^ AnzNachkommastellen
    End Function
    '**********************************************************************************
    'Funktion erst ab Excel 2000 vorhanden, daher Ersatzfunktion für EXCEL97
    Private Function Replace(ByVal T As String, ByVal s As String, ByVal E As String) As String
        Dim pos As Long
        If T =  Or s =  Then Replace = : Exit Function
        pos = 1
        Do
          pos = InStr(pos, T, s, 1)
          If pos = 0 Then Exit Do
          T = Left(T, pos - 1) & E & Right(T, Len(T) - pos - Len(s) + 1)
          pos = pos + Len(E)
        Loop
        Replace = T
    End Function
     
  7. Super, ich danke dir vielmals. Das Makro hat mir sehr geholfen.
     
Die Seite wird geladen...

Excel zu Text für mehrere Dateien - Ähnliche Themen

Forum Datum
Excel VBA Makro zum suchen eines Textes und anschließend einen Breich zu kopieren Microsoft Office Suite 22. Jan. 2015
Excel 2007 - Fehler in =TEXT Funktion ? Windows XP Forum 15. Jan. 2013
Excel: Text in Formel umwandeln Windows XP Forum 21. Mai 2012
Excel 2007 - Text in Grafiklegende formatieren Windows XP Forum 16. Apr. 2012
Excel: Teile von Textfelder darstellen Windows XP Forum 29. Sep. 2009