AW: Makro Formel einfügen, kopieren und CSV
17.08.2011 15:54:40
Tino
Hallo,
hier die gewünschte Anpassung.
Option Explicit
Sub Beispiel()
Dim rngBereich As Range, iCalc As Integer
Dim lngLetzte As Long
Dim varFullPath
'Speicherort für die csv auswählen
varFullPath = Application.GetSaveAsFilename(Format(Now, "dd_mm_yy_hh_mm_ss") & ".csv" _
, "CSV-Dateie (*.csv), *.csv") 'Speichern
If LCase(TypeName(varFullPath)) = "boolean" Then Exit Sub 'Abbrechen gedrückt
With Tabelle1 'Tabelle anpassen
lngLetzte = .Cells(.Rows.Count, 5).End(xlUp).Row
If lngLetzte < 50 Then Exit Sub 'Abbruch keine Daten ab E50
Set rngBereich = .Range("E50", .Cells(lngLetzte, 5))
rngBereich.FormulaR1C1 = "=IF(LEFT(RC[-1],6)=""Sender"",MID(RC[-1],13,8),"""")" 'Formel ?
.Calculate
End With
With Application
iCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
With Workbooks.Add
With .Sheets(1)
.Range("A1").Resize(rngBereich.Rows.Count).Value = rngBereich.Value
End With
Loeschen_Mit_Formel .Sheets(1)
'Pfad für die CSV anpassen ************************************************
.SaveAs Filename:=varFullPath, FileFormat:=xlCSV, CreateBackup:=False
.Close 'Datei schließen
End With
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = iCalc
End With
End Sub
Sub Loeschen_Mit_Formel(oWS As Worksheet)
With oWS.UsedRange
With .Columns(.Columns.Count).Offset(0, 1)
.Formula = "=IF(RC1<>"""",ROW(),TRUE)"
oWS.UsedRange.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
.EntireColumn.Delete
On Error GoTo 0
End With
End With
End Sub
Gruß Tino