Ich habe mich jetzt für ein Formular entschieden und habe alle Bezüge angepasst. Das Makro schreibt jetzt brav alle Daten an die richtige Stelle der Tabelle.
Das einzigste was jetzt noch stört, ist das alles in Anführungszeichen kommt und das die Umlaute falsch dargestellt werden...gibt es dafür eine Lösung???
Hier jetzt noch mal der fertige Code....
Sub ReadfromCSVSimple(fname As Variant, Optional fs As String = ";")
Dim hfile As Integer ' Filehandle bzw. Dateinummer
Dim lAnzahl As Long ' Zähler über alle Zeilen
Dim OneLine As String ' eine Zeile als String
Dim myArr As Variant ' eine Zeile in Felder getrennt
Dim myArrRows As Variant ' Array zum Trennen des csv in mehrere Zeilen
Dim lnglast As Long
Dim zeichen As Variant
Dim iCnt As Integer 'Schleifenzaehler fuer Array. Bei vielen Daten Long nehmen
Dim inhalt
ThisWorkbook.Worksheets("Projektübersicht").Select
lnglast = Cells(Rows.Count, 1).End(xlUp).Row
If IsEmpty(Cells(lnglast, 1)) Then lnglast = Cells(lnglast, 1).End(xlUp).Row
lnglast = lnglast + 1 ' ermittelt die erste freie Zeile
hfile = FreeFile
Open fname For Input As #hfile
inhalt = Input(LOF(hfile), hfile) ' liest alles ein
Close #hfile
If UBound(Split(inhalt, Chr(10))) > 0 Then MsgBox inhalt Else Exit Sub
inhalt = Replace(inhalt, Split(inhalt, Chr(10))(0), 1, 1)
OneLine = inhalt 'die zweite zeile
If OneLine <> "" Then MsgBox OneLine Else MsgBox "die zweite Zeile ist leer" ' ist die Zeile NICHT leer, dann zeige den Inhalt, sonst sag das sie leer ist
myArr = Split(OneLine, ";")
If UBound(myArr) > 49 Then 'es gibt also 44 Einträge geben , 0 und dan bis 43 = 44, Minimum sind 43
With Worksheets("Projektübersicht")
.Cells(lnglast, 3) = Replace(myArr(20), Chr$(49), vbNullString) 'Name/ BV
.Cells(lnglast, 4) = Replace(myArr(22), Chr$(49), vbNullString) 'Land/ BV
.Cells(lnglast, 18) = Replace(myArr(22), Chr$(49), vbNullString) 'Land/ BV
.Cells(lnglast, 7) = Replace(myArr(23), Chr$(49), vbNullString) ' Straße/ BV
.Cells(lnglast, 21) = Replace(myArr(23), Chr$(49), vbNullString) ' Straße/ BV
.Cells(lnglast, 5) = Replace(myArr(24), Chr$(49), vbNullString) ' PLZ/ BV
.Cells(lnglast, 19) = Replace(myArr(24), Chr$(49), vbNullString) ' PLZ/ BV
.Cells(lnglast, 6) = Replace(myArr(25), Chr$(49), vbNullString) 'Ort/ BV
.Cells(lnglast, 20) = Replace(myArr(25), Chr$(49), vbNullString) 'Ort/ BV
.Cells(lnglast, 16) = Replace(myArr(26), Chr$(49), vbNullString) ' Ansprechpartner/ BV
.Cells(lnglast, 22) = Replace(myArr(27), Chr$(49), vbNullString) ' Telefon/ BV
.Cells(lnglast, 23) = Replace(myArr(29), Chr$(49), vbNullString) ' Mail/ BV
.Cells(lnglast, 9) = Replace(myArr(11), Chr$(49), vbNullString) ' Abwicklung über: Firma/ Name
.Cells(lnglast, 8) = Replace(myArr(12), Chr$(49), vbNullString) ' Abwicklung über: Ansprechpartner
.Cells(lnglast, 10) = Replace(myArr(13), Chr$(49), vbNullString) ' Abwicklung über: Land
.Cells(lnglast, 13) = Replace(myArr(14), Chr$(49), vbNullString) ' Abwicklung über Straße
.Cells(lnglast, 11) = Replace(myArr(15), Chr$(49), vbNullString) ' Abwicklung über PLZ:
.Cells(lnglast, 12) = Replace(myArr(16), Chr$(49), vbNullString) ' Abwicklung über Ort
.Cells(lnglast, 14) = Replace(myArr(17), Chr$(49), vbNullString) ' Abwicklung über Telefon:
.Cells(lnglast, 15) = Replace(myArr(19), Chr$(49), vbNullString) ' Abwicklung über Mail
.Cells(lnglast, 33) = Replace(myArr(2), Chr$(49), vbNullString) ' Auftraggeber: Firma/ Name
.Cells(lnglast, 38) = Replace(myArr(3), Chr$(49), vbNullString) ' Auftraggeber: Ansprechpartner
.Cells(lnglast, 34) = Replace(myArr(4), Chr$(49), vbNullString) ' Auftraggeber: Land
.Cells(lnglast, 37) = Replace(myArr(5), Chr$(49), vbNullString) ' Auftraggeber: Straße
.Cells(lnglast, 35) = Replace(myArr(6), Chr$(49), vbNullString) ' Auftraggeber: PLZ:
.Cells(lnglast, 36) = Replace(myArr(7), Chr$(49), vbNullString) ' Auftraggeber: Ort
.Cells(lnglast, 39) = Replace(myArr(8), Chr$(49), vbNullString) ' Auftraggeber: Telefon
.Cells(lnglast, 40) = Replace(myArr(10), Chr$(49), vbNullString) ' Auftraggeber: Mail
.Cells(lnglast, 31) = "Objekt:" & " " & Replace(myArr(30), Chr$(49), vbNullString) _
& vbCrLf & "Objekthersteller:" & " " & Replace(myArr(31), Chr$(49), vbNullString) _
& vbCrLf & "Objektalter:" & " " & Replace(myArr(32), Chr$(49), vbNullString) _
& vbCrLf & "Trägermaterial:" & " " & Replace(myArr(33), Chr$(49), vbNullString) _
& vbCrLf & "Oberfläche:" & " " & Replace(myArr(34), Chr$(49), vbNullString) _
& vbCrLf & "Farbsystem-Nr.:" & " " & Replace(myArr(35), Chr$(49), vbNullString) _
& vbCrLf & "Glanzgrad:" & " " & Replace(myArr(36), Chr$(49), vbNullString) _
& vbCrLf & "Schadensumfang:" & " " & Replace(myArr(37), Chr$(49), vbNullString) _
& vbCrLf & "Schadensort:" & " " & Replace(myArr(38), Chr$(49), vbNullString) _
& vbCrLf & "Schadensursache:" & " " & Replace(myArr(39), Chr$(49), vbNullString) & vbCrLf & "Schadensbeschreibung:" & " " & Replace(myArr(40), Chr$(49), vbNullString)
End With
lnglast = lnglast + 1
MsgBox "erfolgreich eingetragen"
Kill fname
End If
End Sub
Private Sub CommandButton1_Click()
Dim Dateiname As Variant
Dateiname = Application.GetOpenFilename(filefilter:="Textdateien (*.csv), *.csv")
If Dateiname <> "Falsch" Or Dateiname <> False Then
Else
Exit Sub
End If
Call ReadfromCSVSimple(Dateiname, ";")
Unload UserForm3
End Sub
Private Sub CommandButton2_Click()
Unload Me
UserForm4.Show
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
|