einfach und geschmacklos
langsam und gemütlich zum Mitdenken
von Hinten durch die Brust ins Auge
So
Option Explicit
Sub DoIt()
Dim Sh As Worksheet
Dim rngB As Range, rngC As Range, rngF As Range
Dim arrC() As Variant, strf As String, y As Long, c As Range
ActiveSheet.Copy
Set Sh = ActiveSheet
With Sh.UsedRange
On Error Resume Next
Set rngB = .SpecialCells(4)
Set rngF = .SpecialCells(-4123)
Set rngC = .SpecialCells(2)
On Error GoTo 0
If Not rngB Is Nothing Then SubsIt rngB.Address, "B"
If Not rngF Is Nothing Then SubsIt rngF.Address, "F"
If Not rngC Is Nothing Then SubsIt rngC.Address, "C"
End With
strf = Replace(ThisWorkbook.FullName, "xlsm", "txt")
Open strf For Output As #1
With Sh.UsedRange
For y = 1 To .Columns.Count
For Each c In .Columns(y).Cells
Print #1, c.Value
Next c
Next y
End With
Close #1
ActiveWorkbook.Close False
'Ich übernehme keinerlei Gewähr für die Aktualität, Richtigkeit und Vollständigkeit,
'denn was interessiert mich der Schmäh', den ich vor 10 min. geschrieben habe.
'Hauptsache er war gut!
End Sub
Private Sub SubsIt(strAddr As String, ToDo As String)
Dim rnga As Range, rngr As Range, c As Range, strf As String
With Range(strAddr)
For Each rnga In .Areas
For Each rngr In rnga.Rows
For Each c In rngr.Cells
Select Case ToDo
Case "B"
c.NumberFormat = "General"
c.Value = c.Address(0, 0) & " ="
Case "F"
strf = c.FormulaLocal
c.Clear
c.Value = c.Address(0, 0) & " = " & strf
Case "C"
c.NumberFormat = "General"
c.Value = c.Address(0, 0) & " = " & c.Value
End Select
Next c
Next rngr
Next rnga
End With
End Sub
|