Excel Makro funktioniert unter Excel 2003 nicht
18.10.2007 09:37:00
Dr.Hossa
Hallo Leute,
ich habe unter excel 2002 ein Makro geschrieben, jatzt habe ich mir office 2003 beorgt. nun _
funktioniert mein makro nicht mehr.
er bricht bei "ActiveSheet.paste" ab...
allerdings nicht bei jedem, sondern nur bei einem bestimmten.
hier mal der quellcode:
Application.ScreenUpdating = False
ActiveSheet.Shapes("Button 1").Select
Selection.Delete
ActiveSheet.Shapes("Button 2").Select
Selection.Delete
ActiveSheet.Shapes("Button 3").Select
Selection.Delete
MsgBox ("Wählen sie die Überfälligkeitsliste aus die sie bearbeiten möchten")
Überfälligkeitsliste = Application.GetOpenFilename
Sheets("Sheet1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Überfälligkeitsliste _
, Destination:=Range("A1"))
.Name = ("Sheet1")
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(16, 16, 16, 17, 8, 6, 24, 15, 7, 18, 1
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Rows("1:44").Select
Selection.Delete Shift:=xlUp
Dim intRow As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If Not IsNumeric(Cells(intRow, 1)) Then
Rows(intRow).Delete
End If
Next intRow
Range("E1").Select
Dim LastRow As Long
LastRow = Range("F1").End(xlDown).Row
For i = 1 To LastRow
If Cells(i, 6).Value Like "[*]*" Then
Rows(i).Delete
i = i - 1
End If
Next
Range("E1").Select
LastRow = Range("F1").End(xlDown).Row
For i = 1 To LastRow
If Cells(i, 5).Value Like "[*]*" Then
Rows(i).Delete
i = i - 1
End If
Next
Range("J1:L1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll ToRight:=5
Range("AA1500").Select
ActiveSheet.Paste
Range("F1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("Z1500").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = ">30 Days"
Range("B1").Select
ActiveCell.FormulaR1C1 = "11 - 30 Days"
Range("C1").Select
ActiveCell.FormulaR1C1 = "1 - 10 Days"
Range("F1").Select
ActiveCell.FormulaR1C1 = "cust no"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Tot receivables"
Columns("I:I").Select
Selection.Delete Shift:=xlToLeft
Range("I1").Select
ActiveCell.FormulaR1C1 = "BS"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Salesmanager"
Range("K1").Select
ActiveCell.FormulaR1C1 = "CSC"
Columns("J:J").Select
Columns("J:J").EntireColumn.AutoFit
Cells.Select
Range("D1").Activate
Cells.EntireColumn.AutoFit
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Columns("A:A").EntireColumn.AutoFit
Cells.Select
Selection.ColumnWidth = 11.29
Cells.EntireColumn.AutoFit
Range("H2").Select
Range("D1").Select
ActiveCell.FormulaR1C1 = "Überfällig"
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Sheet3").Select
MsgBox ("Wählen sie die Kundenzuordnungstabelle aus, die sie zur Bearbeitung benötigen")
Überfälligkeitsliste = Application.GetOpenFilename
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=" & Überfä _
lligkeitsliste & " ;Mode=Sha" _
, _
"re Deny Write;Extended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB: _
Registry Path="""";Jet OLEDB:Database Password" _
, _
"="""";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking Mode= ;Jet OLEDB:Global Partial Bulk _
Ops=2;Jet OLEDB:Global Bulk Transac" _
, _
"tions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB: _
Encrypt Database=False;Jet OLEDB:Don" _
, _
"'t Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP= _
False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("Sheet1$")
.Name = "Kunden_Zuordnung 060629"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = " & Überfälligkeitsliste"
.Refresh BackgroundQuery:=False
End With
Windows("Überfälligkeitsliste_MAKRO_verantwortlicher.xls").Activate
Sheets("Sheet3").Select
Application.Goto Reference:="R1753C1"
ActiveCell.FormulaR1C1 = "5677"
Range("A1753").Select
Sheets("Sheet1").Select
Sheets("Sheet3").Select
Range("A201").Select
Range(Selection, Selection.End(xlDown)).Select
Dim rngCell As Range
For Each rngCell In Selection.Cells
With rngCell
.NumberFormat = "General"
If IsNumeric(.Text) Then
.Value = CDbl(.Text)
End If
End With
Next 'rngCell
Sheets("Sheet3").Select
Dim LastRow100 As Long
LastRow100 = Range("A200").End(xlDown).Row
Sheets("Sheet1").Select
Range("H2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-3],'Sheet3'!R2C1:R5000C31,30,FALSE)"
Selection.AutoFill Destination:=Range("H2:J2"), Type:=xlFillDefault
Range("H2:J2").Select
Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-4],Sheet3!R2C1:R5000C29,29,FALSE)"
Range("Q2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-12],Sheet3!R2C1:R5000C27,27,FALSE)"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-5],Sheet3!R2C1:R5000C27,27,FALSE)"
Range("H2:J2").Select
Dim LastRow1 As Long
LastRow1 = Range("E2").End(xlDown).Row
Selection.AutoFill Destination:=Range("H2:J" & LastRow1)
Range("H1").Select
Columns("D").Select
Selection.NumberFormat = "#,##0.00"
Dim LastRow3 As Integer
LastRow3 = Range("D2").End(xlDown).Row
Dim lRow As Long
lRow = IIf(Range("D65536") "", 65536, Range("D65536").End(xlUp).Row)
For i = lRow To 1 Step -1
If Range("D" & i) = 0 Then Range("D" & i).EntireRow.Hidden = True
Next i
Dim LastRow4 As Integer
LastRow4 = Range("A1").End(xlDown).Row
Range("A1:J" & LastRow4).Sort Key1:=Range("E2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=5, Criteria1:="0", Operator:=xlAnd
Dim LastRow8 As Integer
LastRow8 = Range("A2").End(xlDown).Row
LastRow8 = LastRow8 + 1
Selection.AutoFilter
Dim LastRowEWB As Long
LastRowEWB = Range("A2").End(xlDown).Row
Range("M1").Select
ActiveCell.FormulaR1C1 = "EWB"
Range("O1").Select
ActiveCell.FormulaR1C1 = "Verantwortlicher"
Range("O2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-8],Sheet3!R2C1:R4000C25,25,FALSE)"
Range("M2").Select
Columns("L:L").EntireColumn.AutoFit
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-6],Sheet3!R2C1:R4000C22,22,FALSE)"
Selection.Copy
Range("M2:M" & LastRowEWB).Select
ActiveSheet.Paste
Range("O2").Select
Selection.Copy
Range("O2:O" & LastRowEWB).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1:O1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=13, Criteria1:="EWB"
Range("A1").Select
Range("A1:O" & LastRowEWB).Sort Key1:=Range("M2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Dim LastRowEWB1 As Long
LastRowEWB1 = LastRowEWB + 4
Range("A" & LastRowEWB1).Select
ActiveSheet.paste
Selection.AutoFilter
bei dem letzten ActiveSheet.paste bricht er ab, mit der Fehlermeldung:
Paste Methode of Worksheetclass failed.
das komische is, wenn ich die Fehlermeldung mit OK bestätige fürt er das ActiveSheet.paste aus. _
hoffe ihr könnt mir helfen.
gruß
Anzeige