Hallo Franz,
alleinstehend funktioniert es wunderbar, jedoch passt es jetzt nicht mehr zum Rest meines "zusammengebastelten" Makros.
Koenntest du dich meiner nochmal annehmen? Leider kann ich den Zusammenhang nicht finden warum jetzt einige Berechnungen nicht mehr vollzogen werden.
Auf jeden Fall schonmal Danke fuer deine Zeit die du bis jetzt investiert hast. Vielen Dank!
PS.: Der Datenbankexport ist ca 130 Spalten breit, und bitte luencht mich nicht wegen der stuemperhaften selects usw.. :-)
Sub Test()
'Definition globale Variable für Range!
Dim lngLast
lngLast = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
S = Now
Debug.Print "Start ZDZt:" + Format(DateDiff("s", S, Now()))
'Screenupdating = False!
Application.ScreenUpdating = False
'Name des Datenblattes= database
Sheets(1).Name = "database"
Sheets(1).Activate
'Formatieren der Spalten
Rows("2:2").Delete
' Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
' TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
' Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
' :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
_
' Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 2), Array( _
13, 1 _
' ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), _
Array _
' (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array( _
26, 1), _
' Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), _
Array( _
' 33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, _
1), _
' Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), _
Array( _
' 46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, _
1), _
' Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), _
Array( _
' 59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, _
1), _
' Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), Array(71, 1), _
Array( _
' 72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), Array(77, 1), Array(78, _
1), _
' Array(79, 1), Array(80, 1), Array(81, 1), Array(82, 1), Array(83, 1), Array(84, 1), _
Array( _
' 85, 1), Array(86, 1), Array(87, 1), Array(88, 1), Array(89, 1), Array(90, 1), Array(91, _
1), _
' Array(92, 1), Array(93, 1), Array(94, 1), Array(95, 1), Array(96, 1), Array(97, 1), _
Array( _
' 98, 1), Array(99, 1), Array(100, 1), Array(101, 1), Array(102, 1), Array(103, 1), _
Array(104 _
' , 1), Array(105, 1), Array(106, 1), Array(107, 1), Array(108, 1), Array(109, 1), Array( _
110, _
' 1), Array(111, 1), Array(112, 1), Array(113, 1), Array(114, 1), Array(115, 1), Array( _
116, 1 _
' ), Array(117, 1), Array(118, 1), Array(119, 1), Array(120, 1), Array(121, 1), Array( _
122, 1) _
' , Array(123, 1), Array(124, 1), Array(125, 1), Array(126, 1), Array(127, 1), Array(128, _
1), _
' Array(129, 1), Array(130, 1)), TrailingMinusNumbers:=True, DecimalSeparator:="."
Dim sFile, arrFieldInfo() As Long, Spalte As Long, Zelle As Range
Dim wks As Worksheet, wksZiel As Worksheet, wbText As Workbook
'Textdatei auswählen
sFile = Application.GetOpenFilename(FileFilter:="Text(*.txt),*.txt", _
Title:="Bitte Datendatei auswählen")
If sFile False Then
'Tabellenblatt in dem die Inhalte der Textdatei eingefügt werden sollen
Set wksZiel = ActiveSheet
'Spaltenformate festlegen
ReDim arrFieldInfo(1 To 150, 1 To 2)
For Spalte = 1 To 150
arrFieldInfo(Spalte, 1) = Spalte
Select Case Spalte
Case 12
arrFieldInfo(Spalte, 2) = 2 'Text
Case Else
arrFieldInfo(Spalte, 2) = 1 'Standard
End Select
Next
'Textdatei öffnen
Application.Workbooks.OpenText Filename:=sFile, startrow:=1, _
DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, _
consecutivedelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
DecimalSeparator:=".", TrailingMinusnumbers:=True, Local:=False, _
Fieldinfo:=arrFieldInfo
Set wbText = ActiveWorkbook
Set wks = wbText.Worksheets(1)
With wks
'Spaltenbreite = Autofit
.UsedRange.EntireColumn.AutoFit
'In bestimmten Spalten Hochkommata durch Leerstring ersetzen
'Dabei werden die nummerischen und Datumswerte in den Zellen konvertiert
.Columns(3).Replace what:="'", replacement:="", lookat:=xlPart
.Columns(8).Replace what:="'", replacement:="", lookat:=xlPart
.Range(.Columns(10), .Columns(11)).Replace what:="'", replacement:="", lookat:=xlPart
'In allen Zellen Wertersetzungen durchführen - konvertiert das führende _
Hochkomma in unsichtbares Text-Kennzeichen
For Each Zelle In .UsedRange
Zelle.Value = Zelle.Value
Next
'Daten in Zieltabelle kopieren - beginnend in Zelle A1
.UsedRange.Copy Destination:=wksZiel.Cells(1, 1)
End With
'Textdatei wieder schliessen ohne speichern
wbText.Close savechanges:=False
End If
Rows("1:1").Interior.ColorIndex = 15
Rows("1:1").Interior.Pattern = xlSolid
Cells.Replace what:="'", replacement:="", lookat:=xlPart
Range("1:1").Select
ActiveWindow.Zoom = 80
Selection.Font.Bold = True
DoEvents
Debug.Print "ZDZt nach Formatierung der Spalten:" + Format(DateDiff("s", S, Now()))
'PVO Formeln:
'SAvr PVO 2008
Range("DZ2").Select
ActiveCell.FormulaR1C1 = "=RC[-80]*RC[-83]/RC[-122]"
Range("DZ2").Select
Selection.AutoFill Destination:=Range("DZ2:DZ" & lngLast), Type:=xlFillDefault
Range("DZ2:DE" & lngLast).Select
Range("DZ1").Select
ActiveCell.FormulaR1C1 = "SPVO 2008"
Range("DZ2").Select
Columns("DZ:DZ").EntireColumn.AutoFit
'SAvr PVO 2009
Range("EA2").Select
ActiveCell.FormulaR1C1 = "=RC[-77]*RC[-80]/RC[-123]"
Range("EA2").Select
Selection.AutoFill Destination:=Range("EA2:EA" & lngLast), Type:=xlFillDefault
Range("EA2:DE" & lngLast).Select
Range("EA1").Select
ActiveCell.FormulaR1C1 = "SPVO 2009"
Range("EA2").Select
Columns("EA:EA").EntireColumn.AutoFit
'APR
Range("EB2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-78]>0,RC[-82]>0),(RC[-78]-RC[-82])*RC[-81]/RC[-124], """")"
Range("EB2").Select
Selection.AutoFill Destination:=Range("EB2:EB" & lngLast), Type:=xlFillDefault
Range("EB2:DE" & lngLast).Select
Range("EB1").Select
ActiveCell.FormulaR1C1 = "APR"
Range("EB2").Select
Columns("EB:EB").EntireColumn.AutoFit
'APR_PCT
Range("EC2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-83]>0,RC[-79]>0),((RC[-79]-RC[-83])*RC[-82]/RC[-125])/(RC[-82]*RC[-79]/RC[- _
125]),"""")"
Range("EC2").Select
Selection.AutoFill Destination:=Range("EC2:EC" & lngLast), Type:=xlFillDefault
Range("EC2:DE" & lngLast).Select
Range("EC1").Select
ActiveCell.FormulaR1C1 = "APR_PCT"
Columns("EC:EC").EntireColumn.AutoFit
'Combo
'Teilergebnisse
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("DZ1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(109,R[2]C:R[15000]C)"
Range("EA1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(109,R[2]C:R[15000]C)"
Range("EB1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(109,R[2]C:R[15000]C)"
Range("EC1").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-2]"
'Format Berechnete Zellen
Columns("DZ:EB").NumberFormat = "#,##0"
Columns("EC:EC").NumberFormat = "0.0%"
Range("EC3:EC" & lngLast).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, _
Formula1:="-0.6"
With Selection.FormatConditions(1).Font
.Bold = False
.Italic = True
.ColorIndex = 3
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual _
, Formula1:="0.6"
With Selection.FormatConditions(2).Font
.Bold = False
.Italic = True
.ColorIndex = 3
End With
'Insert "x"
Range("ED2").Select
ActiveCell.FormulaR1C1 = "x"
'Autofilter
Rows("2:2").AutoFilter
Cells.Columns.AutoFit
'Gruppieren
Columns("S:DY").Select
Range("DY1").Activate
Selection.Columns.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Columns("O:Q").Select
Range("Q1").Activate
Selection.Columns.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Columns("M:M").Select
Range("M1").Activate
Selection.Columns.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Columns("e:k").Select
Range("K1").Activate
Selection.Columns.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
'Split
ActiveWindow.SplitRow = 2
ActiveWindow.FreezePanes = True
'Combo
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A3").FormulaR1C1 = "=RC[1]&RC[12]&RC[23]"
Range("A3").AutoFill Destination:=Range("A3:A" & lngLast), Type:=xlFillDefault
Range("A3:A" & lngLast).Select
Range("A2").FormulaR1C1 = "COMBO"
Columns("A:A").Copy
Columns("A:A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A:A").Columns.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Application.Calculate
'Aussortieren der fehlerhaften Berechnugen
Dim rng As Range, cell As Range, fmla As String
Set rng = Cells.SpecialCells(xlCellTypeFormulas, 16)
For Each cell In rng
fmla = Right(cell.Formula, Len(cell.Formula) - 1)
cell.Formula = "=if(iserror(" & fmla & "), """"," & fmla & ")"
Next
Application.Calculate
End Sub