Thema Datum  Von Nutzer Rating
Antwort
25.12.2015 17:29:48 kaba
NotSolved
25.12.2015 21:54:30 Gast84843
NotSolved
26.12.2015 00:21:18 Gast24916
NotSolved
26.12.2015 11:04:08 Gast31427
NotSolved
26.12.2015 19:47:04 Gast44228
NotSolved
26.12.2015 21:25:23 Gast33581
NotSolved
27.12.2015 17:07:30 Gast15252
NotSolved
27.12.2015 18:33:40 Gast11408
NotSolved
27.12.2015 21:46:20 Gast79845
NotSolved
27.12.2015 23:11:01 Gast51998
NotSolved
28.12.2015 00:18:41 Gast63692
NotSolved
28.12.2015 00:23:42 Gast45800
NotSolved
28.12.2015 12:13:26 Gast20098
NotSolved
28.12.2015 13:17:10 Gast28188
NotSolved
28.12.2015 16:27:18 Gast74702
NotSolved
28.12.2015 16:39:19 Gast79553
NotSolved
28.12.2015 20:34:51 Gast47519
NotSolved
29.12.2015 01:30:11 Gast34909
NotSolved
29.12.2015 08:37:15 Gast24437
NotSolved
29.12.2015 09:51:40 Gast52305
NotSolved
29.12.2015 13:43:19 Gast74900
NotSolved
29.12.2015 17:10:59 kaba
NotSolved
29.12.2015 22:05:52 Gast93041
NotSolved
29.12.2015 23:00:04 Gast65849
NotSolved
30.12.2015 10:21:02 Gast36151
*****
Solved
30.12.2015 20:23:27 kaba
NotSolved
30.12.2015 22:54:25 Gast78976
NotSolved
Blau 3 Probleme mit meinem Text-Import script
31.12.2015 11:51:11 Gast23361
NotSolved
31.12.2015 12:55:44 Gast2945
NotSolved
31.12.2015 13:09:25 Gast71405
*****
Solved
03.01.2016 12:42:43 kaba
Solved
31.12.2015 11:40:43 Gast8396
NotSolved
31.12.2015 12:57:09 Gast64794
NotSolved

Ansicht des Beitrags:
Von:
Gast23361
Datum:
31.12.2015 11:51:11
Views:
895
Rating: Antwort:
  Ja
Thema:
3 Probleme mit meinem Text-Import script

Und hier die Version mit input line - sollte auch gehen!

 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
Dim dateien()
Option Explicit
    
Sub DateienLesen()
    Call EventsOff
    Dim DateiName As String
    Dim quelle As String
    Dim i As Long
    Dim j As Long
    Dim zeile As String
    Dim inhalt
    Dim ende
    Dim nr
    Dim utf As Boolean
    Dim prüfen As Boolean
    Dim erstezeile As Boolean
    Dim text As String
     
    ReDim dateien(0)
    dateien(0) = 0
        
    quelle = "       " 'Pfad eintragen
    Call txtsuchen(quelle)
   
    If dateien(0) = 0 Then
    MsgBox "Keine .txt Dateien gefunden!"
    Else
    'Daten auslesen
           
        For i = 1 To dateien(0)
        DateiName = dateien(i)
        ende = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
        ende = ende + 2
          
        nr = FreeFile()
        utf = False
        prüfen = False
        erstezeile = False
          
        Open DateiName For Input As #nr
        Do While Not EOF(nr)
           
            Line Input #nr, zeile
               
            inhalt = Split(zeile, Chr(9))
              
            If prüfen = False Then
                If Len(inhalt(0)) > 2 Then
                    If Asc(Left(inhalt(0), 1)) = 239 And Asc(Mid(inhalt(0), 2, 1)) = 187 And Asc(Mid(inhalt(0), 3, 1)) = 191 Then utf = True
                End If
                prüfen = True
                text = inhalt(2)
            End If
                  
            For j = 0 To UBound(inhalt)
                                 
                If utf = True Then
                    If erstezeile = False Then
                        If j = 0 Then inhalt(j) = Mid(inhalt(j), 4, Len(inhalt(j)))
                        If IsNumeric(inhalt(j)) Then inhalt(j) = Replace(inhalt(j), ",", ".")
                        ActiveSheet.Cells(ende, 3 + j) = FromUTF8String(inhalt(j))
                        erstezeile = True
                    Else
                        If IsNumeric(inhalt(j)) Then inhalt(j) = Replace(inhalt(j), ",", ".")
                        ActiveSheet.Cells(ende, 3 + j) = FromUTF8String(inhalt(j))
                    End If
                Else
                    If IsNumeric(inhalt(j)) Then inhalt(j) = Replace(inhalt(j), ",", ".")
                    ActiveSheet.Cells(ende, 3 + j) = inhalt(j)
                End If
            Next j
            ActiveSheet.Cells(ende, 6) = text
            ende = ende + 1
        Loop
           
        Close #nr
    
        Next i
    End If
    Call tausch
      
    ActiveSheet.Range("C:D").Columns.AutoFit
    ActiveSheet.Range("C:D").NumberFormat = "0.000000"
    Call EventsOn
End Sub
     
Public Sub EventsOff()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub
     
Public Sub EventsOn()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
   
Function txtsuchen(quelle As String)
Dim suche
Dim ordner()
Dim i As Long
    
ReDim ordner(0)
ordner(0) = 0
ChDrive (Left(quelle, 3))
ChDir (quelle)
   
'Ordner durchschauen
suche = Dir(quelle & "\*.*", vbDirectory)
    
Do Until suche = ""
    'Normale Dateien rausfiltern
    If (GetAttr(quelle & "\" & suche) = 16) Then
        'die hier ankommen, sind Ordner, extra speichern
        ordner(0) = ordner(0) + 1
        ReDim Preserve ordner(ordner(0))
        ordner(ordner(0)) = suche
    Else
        If Right(suche, 4) = ".txt" Then
            dateien(0) = dateien(0) + 1
            ReDim Preserve dateien(dateien(0))
            dateien(dateien(0)) = quelle & "\" & suche
        End If
    End If
            
    suche = Dir()
Loop
'jetzt durch die Ordner gehen
For i = 1 To UBound(ordner)
    If Dir(ordner(i), vbNormal) = "" And Left(ordner(i), 1) <> "." Then
        Call txtsuchen(quelle & "\" & ordner(i))
        ChDir (quelle)
    End If
Next
End Function
  
Function FromUTF8String(ByVal s As String) As String
   Dim i As Integer, b(2) As Byte
     
   i = 1
   s = s & Chr(0) & Chr(0)
   Do While i <= Len(s) - 2
      b(0) = Asc(Mid(s, i, 1))
      b(1) = Asc(Mid(s, i + 1, 1))
      b(2) = Asc(Mid(s, i + 2, 1))
      If (b(0) And &HE0) = &HE0 Then
         FromUTF8String = FromUTF8String & ChrW((b(0) And &HF) * CLng(&H1000) + (b(1) And &H3F) * CLng(&H40) + (b(2) And &H3F))
         i = i + 3
      ElseIf (b(0) And &HC0) = &HC0 Then
         FromUTF8String = FromUTF8String & ChrW((b(0) And &H1F) * &H40 + (b(1) And &H3F))
         i = i + 2
      Else
         FromUTF8String = FromUTF8String & Chr(b(0))
         i = i + 1
      End If
   Loop
End Function
  
Function tausch()
Dim i As Long
For i = 1 To ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
  
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(132), "Ä")
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(164), "ä")
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(150), "Ö")
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(182), "ö")
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(156), "Ü")
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(188), "ü")
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(159), "ü")
Next i
  
End Function

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
25.12.2015 17:29:48 kaba
NotSolved
25.12.2015 21:54:30 Gast84843
NotSolved
26.12.2015 00:21:18 Gast24916
NotSolved
26.12.2015 11:04:08 Gast31427
NotSolved
26.12.2015 19:47:04 Gast44228
NotSolved
26.12.2015 21:25:23 Gast33581
NotSolved
27.12.2015 17:07:30 Gast15252
NotSolved
27.12.2015 18:33:40 Gast11408
NotSolved
27.12.2015 21:46:20 Gast79845
NotSolved
27.12.2015 23:11:01 Gast51998
NotSolved
28.12.2015 00:18:41 Gast63692
NotSolved
28.12.2015 00:23:42 Gast45800
NotSolved
28.12.2015 12:13:26 Gast20098
NotSolved
28.12.2015 13:17:10 Gast28188
NotSolved
28.12.2015 16:27:18 Gast74702
NotSolved
28.12.2015 16:39:19 Gast79553
NotSolved
28.12.2015 20:34:51 Gast47519
NotSolved
29.12.2015 01:30:11 Gast34909
NotSolved
29.12.2015 08:37:15 Gast24437
NotSolved
29.12.2015 09:51:40 Gast52305
NotSolved
29.12.2015 13:43:19 Gast74900
NotSolved
29.12.2015 17:10:59 kaba
NotSolved
29.12.2015 22:05:52 Gast93041
NotSolved
29.12.2015 23:00:04 Gast65849
NotSolved
30.12.2015 10:21:02 Gast36151
*****
Solved
30.12.2015 20:23:27 kaba
NotSolved
30.12.2015 22:54:25 Gast78976
NotSolved
Blau 3 Probleme mit meinem Text-Import script
31.12.2015 11:51:11 Gast23361
NotSolved
31.12.2015 12:55:44 Gast2945
NotSolved
31.12.2015 13:09:25 Gast71405
*****
Solved
03.01.2016 12:42:43 kaba
Solved
31.12.2015 11:40:43 Gast8396
NotSolved
31.12.2015 12:57:09 Gast64794
NotSolved