Sub
Muster()
Application.ScreenUpdating =
False
ActiveSheet.Copy
Umlaute
Ausgeben
ActiveWorkbook.Close
False
Application.ScreenUpdating =
True
End
Sub
Sub
Ausgeben()
Dim
rngU
As
Range, c
As
Range, d
As
Range
Dim
strFile
As
String
Dim
x
As
Long
, z
As
Long
Set
rngU = Sheets(1).UsedRange
z = rngU.Columns.Count
strFile = Replace(ThisWorkbook.FullName,
"xlsm"
,
"xml"
)
Open strFile
For
Output
As
#1
Print #1,
"myHeader"
For
Each
c
In
rngU.Columns(1).Cells
Print #1, c.Text
For
x = 1
To
z - 1
Set
d = c.Offset(, x)
If
Not
IsEmpty(d)
Then
Print #1, d.Text
Next
x
Next
c
Close #1
End
Sub
Sub
Umlaute()
Const
C_From
As
String
=
"Ä,Ö,Ü,ä,ö,ü,ß"
Const
C_To
As
String
=
"Ae,Oe,Ue,ae,oe,ue,ss"
Dim
rngU
As
Range
Dim
arrFrom()
As
String
, arrTo()
As
String
Dim
x
As
Long
arrFrom = Split(C_From,
","
)
arrTo = Split(C_To,
","
)
Set
rngU = Sheets(1).UsedRange
For
x = LBound(arrFrom)
To
UBound(arrFrom)
rngU.Replace What:=arrFrom(x), Replacement:=arrTo(x), LookAt:=xlPart, MatchCase:=
True
Next
x
End
Sub