Externe Dateien

 

Home
Nach oben

Last Update 20.07.2004

Copyright  2003
Ramses (C)

 

Übersicht

Externe *.ini Datei öffnen in Array einlesen und einzelne Zeilen ändern

Externe ASCII (*.txt, *.dat) Datei öffnen und in ein Arbeitsblatt einfügen

Externe CSV mit mehr als 256 Spalten und mehr als 65536 Zeilen in EXCEL einfügen

Dateien die in einer Tabelle aufgelistet sind, aus einem Ordner in einen anderen kopieren

Daten aus externen Mappen lesen ohne diese zu öffnen

Suchbegriff in allen Mappen eines definierten Verzeichnisses suchen

 


Dieser Code wurde entwickelt um Vorgaben aus einer INI Datei in einem Array zu halten, damit Daten in einem Arbeitsblatt zu vergleichen, und eventuell bei Änderungen das Array zu ändern und anschliessend die INI-Datei neu zu schreiben

 

Sub Write_New_Lines_in_extern_File()

'Hilfsvariable für Anzahl Datensätze

Dim Text1 As String

'Variablen für den Array nötig

Dim TxtLines As Long, i As Long

Dim TextArr As Variant

'Schliessen einer geöffneten Datei

Close #1

'1. Öffnen der Datei

'Den Namen und Pfad bitte anpassen

Open "c:\demo.ini" For Input As #1

'Die anzahl ist nötig um die Grösse des Arrays zu deklarieren

'Zähler auf 0 setzen

TxtLines = 0

Do While Not EOF(1) ' Schleife bis Dateiende.

       Input #1, Text1 ' Hilfsvariable zum einlesen verwenden

'      Zähler hochzählen

      TxtLines = TxtLines + 1

Loop

'Schliessen der Datei weil Dateiende erreicht wurde

Close #1

'Erneutes Öffnen um zum Dateianfang zu kommen

Open "c:\demo.init" For Input As #1 ' Datei zum Einlesen öffnen.

'Array neu auf die Anzahl der Linien initialisieren

ReDim TextArr(TxtLines)

'Einlesen der Dateien in das Array

For i = 1 To TxtLines

       Input #1, TextArr(i)

Next i

Close #1

'Im Prinzip kannst du jetzt mit

TextArr(5) = "Mein Neuer Text " & TextArr(5)

'in der Zeile 5 den Text an dieser Zeile ändern

'oder mit

TextArr(6) = "Mein Neuer Text "

'in der Zeile 6 einen anderen Text einsetzen

'Zum zurückschreiben musst du den ganzen Array

'wieder in die Datei zurückschreiben.

Open "C:\Demo.ini" For Output As #1

For i = 1 To TxtLines

        Write #1, TextArr(i)

Next i

Close #1

End Sub

 

 

Zurück


 

 

Dieser Code wurde entwickelt, um eine Textdatei oder CSV die nicht richtig konvertiert wird beim öffnen, schnell einzulesen und in ein aktuelles Arbeitsblatt zu schreiben, ohne eine neue Arbeitsmappe zu erstellen

 

Sub Read_Extern_File()

'Hilfsvariable für Anzahl Datensätze

Dim Text1 As String

'Variablen für den Array nötig

Dim TxtLines As Long, i As Long

Dim TextArr As Variant

Dim ReadFile As String

'Dialog öffnen auf Basis von *.txt, *.log oder *.dat Files

ReadFile = Application.GetOpenFilename("DAT Files (*.txt; *.log; *.dat),")

'Schliessen einer geöffneten Datei

Close #1

'1. Öffnen der Datei

'Den Namen und Pfad bitte anpassen

Open ReadFile For Input As #1

'Die anzahl ist nötig um die Grösse des Arrays zu deklarieren

'Zähler auf 0 setzen

TxtLines = 0

Do While Not EOF(1) ' Schleife bis Dateiende.

     Input #1, Text1 ' Hilfsvariable zum einlesen verwenden

'         Zähler hochzählen

         TxtLines = TxtLines + 1

Loop

'Schliessen der Datei weil Dateiende erreicht wurde

Close #1

'Erneutes Öffnen um zum Dateianfang zu kommen

Open ReadFile For Input As #1 ' Datei zum Einlesen öffnen.

'Array neu auf die Anzahl der Linien initialisieren

ReDim TextArr(TxtLines)

'Einlesen der Dateien in das Array

For i = 1 To TxtLines

       Input #1, TextArr(i)

Next i

Close #1

'Daten in aktuelles Sheet schreiben

For i = 1 To TxtLines

        Cells(i, 1) = TextArr(i)

Next i

End Sub

 

 

Zurück

 

 

 

Dieser Code wurde für das Export-File aus einer Datenbank entwickelt, welche Daten als CSV zur Verfügung stellt allerdings mit 912 Spalten und über 120000 Datensätzen.

Die Aufgabe bestand darin, die Spalten 289 bis 534 in ein EXCEL - Sheet einzufügen

 

Sub Read_Externe_Datei_mit_Semikolon_in_Array()

'Variable für die Statusbar

Dim OldStatus As Variant

'Hilfsvariable für Anzahl Datensätze

Dim Text1 As String

'Variablen für den Array nötig

Dim TxtLines As Long, i As Long

Dim TextArr As Variant

'Variablen für den Umwandlungsprozess des TextArrays

Dim CC As Integer, Cr As Long

Dim ArrRun As Long, FoundPlace As Integer, ReplCounter As Integer

Dim FindChr As String, ArrReplace As String, TempTextArr As String, ReadFile as String

'Schliessen einer geöffneten Datei

Close #1

'1. Öffnen der Datei

ReadFile = Application.GetOpenFilename("DAT Files (*.csv),")

Open ReadFile For Input As #1

'Die anzahl ist nötig um die Grösse des Arrays zu deklarieren

'Zähler auf 0 setzen

TxtLines = 0

Do While Not EOF(1) ' Schleife bis Dateiende.

     Input #1, Text1 ' Hilfsvariable zum einlesen verwenden

          'Zähler hochzählen

         TxtLines = TxtLines + 1

Loop

'Schliessen der Datei weil Dateiende erreicht wurde

Close #1

'Erneutes Öffnen um zum Dateianfang zu kommen

Open ReadFile For Input As #1 ' Datei zum Einlesen öffnen.

'Array neu initialisieren

ReDim TextArr(TxtLines)

'Einlesen der Dateien in das Array

For i = 1 To TxtLines

      Input #1, TextArr(i)

Next i

Close #1

'Umwandeln der ersten Semikolons in allen Datensätzen in Leerstellen

'Dieser ganze Textbereich wird anschliessend abgetrennt und verworfen

'Danach werden die jeweiligen Werte zwischen den Semikolons in die Spalten

'untereinander geschrieben

'------

'Variablen für Cell-Adressierung

CC = 1

Cr = 1

'Aufforderung wieviele Spalten zurückgesetzt werden sollen

ReplCounter = InputBox("Wieviele Spalten von links( Semikolons ) sollen entfernt werden?", "Spaltenreduktion", 150)

'Variable für das zu ersetzende Zeichen

'Hier eventuell anpassen

FindChr = ";"

'Status der Anzeige aufnehmen

OldStatus = Application.StatusBar

'Bildschirmaktualisierung ausschalten

Application.ScreenUpdating = False

For ArrRun = 1 To TxtLines

       'Statusbar für Benutzerinformation verwenden

       Application.DisplayStatusBar = True

       Application.StatusBar = "Datensatz " & ArrRun & " von " & TxtLines & " wird bearbeitet"

       'Die ersten gewählten Semikolons ersetzen

       On Error Resume Next

       For i = 1 To ReplCounter

'      Suchen des ersten Vorkommens

              FoundPlace = InStr(1, TextArr(ArrRun), FindChr)

             'Aus der Schleife aussteigen wenn weniger Semikolons gefunden wurden

       If FoundPlace = 0 Then

             'Hier muss der Ausstieg sein wenn weniger als x Semikolon gefunden

'                          werden. Dann muss die Arrrun Schleife neu starten   

             Exit For

       End If

      'Ersetzen des Zeichens

            ArrReplace = Application.WorksheetFunction.Replace(TextArr(ArrRun), FoundPlace, 1, "")

            'Zurückschreiben des Wertes in den Array

            TextArr(ArrRun) = ArrReplace

       Next i

       'Kürzen des Arrays bis zum ersten Semikolon

    If InStr(1, TextArr(ArrRun), FindChr) <> 0 Then

               TextArr(ArrRun) = Right(TextArr(ArrRun), Len(TextArr(ArrRun)) - InStr(1, TextArr(ArrRun), FindChr))

       End If

    'Temporären String für den Datensatz schreiben

    'dies ist nötig wegen der Schleife

       TempTextArr = TextArr(ArrRun)

       'Schreiben des Restes in die Spalten und Zeilen

       'Wiederholungen basieren auf der Länge des restlichen Textes

       'weil die Anzahl der Semikolons unbekannt ist

       For i = 1 To Len(TextArr(ArrRun))

            'Semikolon im Array neu suchen

            FoundPlace = InStr(1, TempTextArr, FindChr)

            'Aus der Schleife aussteigen wenn weniger Semikolons gefunden wurden

            'und Werte in die Zellen schreiben

      'dabei werden die horizontalen Datensätze in vertikale konvertiert

            If FoundPlace = 0 Then

                    Cells(Cr, CC) = TempTextArr

                    Exit For

            Else

                   Cells(Cr, CC) = Left(TempTextArr, FoundPlace - 1)

            End If

            'Zeilenzähler hochsetzen

            Cr = Cr + 1

            'String des temporären Array-Datensatzes neu schreiben mit dem Rest

            TempTextArr = Right(TempTextArr, Len(TempTextArr) - InStr(1, TempTextArr, FindChr))

       Next i

       'Nächste Spalte

       CC = CC + 1

       'Zeile wieder auf 1 setzen

       Cr = 1

Next ArrRun

Application.StatusBar = OldStatus

Application.ScreenUpdating = True

End Sub

 

Zurück


 

 

Dateien die in einer Tabelle aufgelistet sind, aus einem Ordner in einen anderen kopieren

Tabelle1

      
 ABC
1DateinamenKopier OrdnerZiel Ordner
2text1.txtC:\Test1\C:\Test2\
3text2.txt  


Option Explicit

Sub Copy_Files_based_on_Excel_Sheet()
'(c) Ramses
On Error GoTo myErrorHandler
Dim i As Long, Cr As Long, Cc As Integer
Dim wks As Worksheet, Qe As Integer
Dim strCFolder As String, strTFolder As String
Dim myFs As Object
'Erstellen des FileSystemObjectes
Set myFs = CreateObject("Scripting.FileSystemObject")
'Tabelle wo die Filenamen stehen
Set wks = Worksheets("Tabelle1")
'Spalte in der die Filenamen stehen
Cc = 1
'Letzten Eintrag festlegen
Cr = Cells(65536, Cc).End(xlUp).Row
'Ordner in dem die Dateien liegen
'Achtung: Mit Backslash am Schluss
strCFolder = "C:\test1\"
If Not myFs.folderexists(strCFolder) Then
    Qe = MsgBox("Der Ordner aus dem die Dateien kopiert werden sollen existiert nicht.", vbCritical + vbOKOnly, "Abbruch")
    Exit Sub
End If
'Alternativ wenn der Pfad in einer Zelle steht. Hier in B1
'strCFolder = wks.Cells(2,2)
'Ordner in den kopiert werden soll
strTFolder = "C:\test2\"
'Alternativ wenn der Pfad in einer Zelle steht. Hier in B1
'strTFolder = wks.Cells(2,3)
If Not myFs.folderexists(strCFolder) Then
    Qe = MsgBox("Der Ordner in den die Dateien kopiert werden sollen existiert nicht.", vbCritical + vbOKOnly, "Abbruch")
    Exit Sub
End If
'Kopierschleife starten
'1 wenn die Filenamen in Zeile 1 beginnen,
'sonst ab welcher Zeile die Filenamen beginnen
For i = 1 To Cr
    myFs.CopyFile strCFolder & wks.Cells(i, Cc).Text, strTFolder & wks.Cells(i, Cc).Text
Next i
'Fehlerbehandlung
myErrorExit:
Exit Sub

myErrorHandler:
MsgBox (Err.Number & ": " & Err.Description)
Resume myErrorExit
End Sub 

Zurück


Daten aus externen Mappen lesen ohne diese zu öffnen

Sub Read_All_Datas_from_defined_Workbooks_without_Opening()
'by Ramses
'Liest alle Daten aus geschlossenen Arbeitsblättern
'aus einem bestimmten Bereich ein.
'Alle eingelesenen Daten werden untereinander aufgelistet.
'Die Daten werden in Dateien mit dem Datei-Teilbegriff "Report"
'gesucht und eingelesen
Dim As Long, totFiles As Long
Dim ColCounter As Integer, rowCounter As Long
Dim As Integer, k As Integer
Dim gefFile As String, TeilName As String
Dim Suchpfad As String, Suchbegriff As String, Dateiform As String
Dim tmpPfad As String, tmpName As String, tmpFile As String
Dim curWB As Workbook, tarwks As Worksheet, datWKS As String
Dim oldStatus As Variant
Dim myR1 As String, myR2 As String, myR3 As String
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", "D:") 'Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True 'zur definitiven Ausführung auf False setzen
oldStatus = Application.StatusBar
'ZählVariablen setzen
rowCounter = 1
ColCounter = 2
'Variablen für aktive Mappe setzen
Set curWB = Workbooks(ThisWorkbook.name)
Set tarwks = curWB.Worksheets("Tabelle1")
'zu kopierende Bereiche definieren
'Variablen für den DateiNamen der entsprechenden Tabelle ersezten
TeilName = "Report"
'Tabellenname in der Mappe mit dem Teilstring "TeilName"
datWKS = "Summary"
'zu lesende Bereich definieren
myR1 = datWKS & "'!R3C2"
myR2 = datWKS & "'!R17C4"
'Datumsformat in Spalte D zuweisen
Columns(4).NumberFormat = "m/d/yyyy"
'Dateisuche starten
With Application.FileSearch
    .LookIn = Suchpfad
    .SearchSubFolders = False
    .FileName = Dateiform
    'Wenn gefunden,..
    'Schleifenauswertung beginnen
    If .Execute() > 0 Then
        totFiles = .FoundFiles.count
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.count
            gefFile = .FoundFiles(i)
            'Namen und String zusammensetzen
            tmpName = Right(gefFile, Len(gefFile) - InStrRev(gefFile, "\", -1))
            tmpPfad = Left(gefFile, Len(gefFile) - Len(tmpName))
            tmpFile = "'" & tmpPfad & "[" & tmpName & "]"
            'Die Formel für das Excel4-Macro muss im R1C1 - Format erstellt werden
            'Auch die Rechteckklammern müssen eingebaut werden
            'Hochkomma's nicht vergessen !!
            ''D:\[Muster.xls]Summary'!R3C2
            If UCase(Left(Right(gefFile, Len(gefFile) - 3), Len(TeilName))) = UCase(TeilName) Then
                'In Tabelle eintragen
                tarwks.Cells(rowCounter, 1) = Application.ExecuteExcel4Macro(tmpFile & myR1)
                tarwks.Cells(rowCounter, 2) = Application.ExecuteExcel4Macro(tmpFile & myR2)
                tarwks.Cells(rowCounter, 2).NumberFormat = "0.00%"
                'Zwei neue Schleifen um die einzelnen zellen in
                'den Zieldateien auszulesen
                'Datenbereich von B23 : F39 einlesen
                For k = 23 To 39
                    For n = ColCounter To 6
                        myR3 = datWKS & "'!R" & k & "C" & n & ":R" & k & "C" & n
                        tarwks.Cells(rowCounter, n + 1) = Application.ExecuteExcel4Macro(tmpFile & myR3)
                    Next n
                    rowCounter = rowCounter + 1
                Next k
                rowCounter = rowCounter + 1
            End If
        Next i
    End If
End With
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

Zurück


 

Suchbegriff in allen Mappen eines definierten Verzeichnisses suchen

Sub MultiSeek_in_Folder()
'By Ramses
'Durchsucht in einem Verzeichnis alle Mappen nach einem Suchbegriff
Dim Suchpfad As String, findStr As String, Dateiform As String, msgTxt As String
Dim Qe As Integer, myMatch As String, sAddress As String
Dim wks As Worksheet, wb As Workbook
Dim myRng As Range, totFiles As Integer, i As Integer, gefFile As Variant
Dim oldStatus As Variant
'Variablen füllen
Dateiform = "*.xls"
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll:", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
findStr = InputBox("Geben Sie den Text an der gesucht werden soll", "Textteil", "Suchtext")
If findStr = "" Then Exit Sub
msgTxt = "Soll auf exakte Übereinstimmung mit dem Fragment gesucht werden ? "
msgTxt = msgTxt & vbCrLf & "Bei ""Nein"" werden als Ergebnisse angezeigt,"
msgTxt = msgTxt & vbCrLf & "bei denen nur ein Teil des Textes mit:"" " & findStr & " "" übereinstimmt !"
Qe = MsgBox(msgTxt, vbQuestion + vbYesNo, "Suchroutine")
If Qe = vbOK Then
    myMatch = xlWhole
Else
    myMatch = xlPart
End If
'Bildschirmaktualisierung abschalten
Application.ScreenUpdating = True 'Nicht ausschalten = True
'Text der Statusbar und alten Status aufnehmen
oldStatus = Application.StatusBar
'Start der Suchroutine
With Application.FileSearch
    .NewSearch
    .LookIn = Suchpfad
    .FileName = Dateiform
    If .Execute() > 0 Then
        totFiles = .FoundFiles.count
        'Ausgabe in Statusbar
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.count
            gefFile = .FoundFiles(i)
            Set wb = Application.Workbooks.Open(gefFile)
            Application.StatusBar = "Datei " & i & " von " & totFiles & " wird bearbeitet"
            For Each wks In wb.Worksheets
                Set myRng = wks.Cells.Find(What:=findStr, _
                        LookAt:=myMatch, LookIn:=xlFormulas)
                If Not myRng Is Nothing Then
                    sAddress = myRng.Address
                    Do
                        Application.GoTo myRng, True
                        'Für die Automation kann die "If"-Anweisung auskommentiert werden
                        If MsgBox("Weiter suchen", vbYesNo + vbQuestion) = vbNo Then
                            GoTo exitsearch
                        End If
                        '--
                        Set myRng = Cells.FindNext(after:=ActiveCell)
                    Loop
                End If
            Next
            wb.Close False
            Set wb = Nothing
        Next i
    End If
    'Exitfor:
End With
MsgBox prompt:="Keine neue Fundstelle!"
exitsearch:
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

Zurück