AW: Spaltendaten in Textdatei ausgeben
28.04.2018 11:59:29
Sepp
Hallo Wolfgang,
in ein allgemeines Modul.
Modul Modul1
Option Explicit
Private Enum SORT_ORDER
Sort_Unsorted = 0
Sort_Ascending = 1
Sort_Descending = -1
End Enum
Sub createTXTFiles()
Dim lngCol As Long, lngLast As Long
Dim strPath As String, strFile As String, strText As String
Dim varIn As Variant, varOUT As Variant
Dim ff As Integer
strPath = "D:\Forum\" 'Ausgabepfad - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
With Sheets("Tabelle1")
For lngCol = 1 To .Cells(2, .Columns.Count).End(xlToLeft).Column
lngLast = Application.Max(4, .Cells(.Rows.Count, lngCol).End(xlUp).Row)
If Application.CountA(.Range(.Cells(4, lngCol), .Cells(lngLast, lngCol))) > 0 Then
varIn = .Range(.Cells(4, lngCol), .Cells(lngLast, lngCol))
varOUT = toArrayUnique(varIn, Sort_Unsorted)
If IsArray(varOUT) Then
strText = Join(varOUT, vbLf)
strFile = strPath & "Symbole_" & .Cells(3, lngCol).Text & ".txt"
ff = FreeFile
Open strFile For Output As #ff
Print #ff, strText;
Close #ff
End If
End If
Next
End With
End Sub
Private Function toArrayUnique(ByRef Field As Variant, Optional SortOrder As SORT_ORDER = Sort_Ascending) As Variant
Dim objArrayList As Object
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = Lbound(Field, 1) To Ubound(Field, 1)
For lngC = Lbound(Field, 2) To Ubound(Field, 2)
If Not .Contains(Trim(Field(lngR, lngC))) Then
If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
End If
Next
Next
If SortOrder <> Sort_Unsorted Then .Sort
If SortOrder < Sort_Unsorted Then .Reverse
toArrayUnique = .toArray
End With
Exit Function
ErrExit:
toArrayUnique = -1
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0