Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
916to920
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
916to920
916to920
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Excel Makro funktioniert unter Excel 2003 nicht

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ß 


7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Makro funktioniert unter Excel 2003 nich
18.10.2007 09:45:00
Ramses
Hallo
Auf Verdacht und ins Blaue
Ändere
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Dim LastRowEWB1 As Long
LastRowEWB1 = LastRowEWB + 4
Range("A" & LastRowEWB1).Select
ActiveSheet.paste
mal in die Kurzfassung
Dim LastRowEWB1 As Long
LastRowEWB1 = LastRowEWB + 4
Range(Selection, Selection.End(xlDown)).Copy Destination:=Range("A" & LastRowEWB1)
Gruss Rainer

AW: Excel Makro funktioniert unter Excel 2003 nich
18.10.2007 12:33:00
Dr.Hossa
hallo,
zu Chris:
ich weiß, das dich den Beitrag schon mal gepostet habe, ich bekomme leider nur keinen anderen Hinweiße, deswegen dachte ich, ich versuchs mal hier.
zu Rainer:
das Funktioniert leider auch nicht, er bricht an gleicher Stelle, mit der selben Fehlermeldung ab.
noch irgendwelche anderen Ideen?

Anzeige
AW: Excel Makro funktioniert unter Excel 2003 nich
18.10.2007 13:13:00
Ramses
Hallo
Setz mal einen Haltepunkt bei
Range("A" & LastRowEWB1).Select
und schau mal welchen Wert die Variable eigentlich hat
Gruss Rainer

AW: Excel Makro funktioniert unter Excel 2003 nich
18.10.2007 13:19:00
Dr.Hossa
der Wist 347, so wie er auch sein soll.
nach dem ich die Fehlermeldung bekomme und auf "end" oder "debug" klicke, führt er die aktion auch aus.
ne andere idee, die ich habe wäre, die Fehlermeldung zu unterdrücken, so das der code weiterläuft, allerdings weiß ich nich wie ich das da einbaue, wenn es überhaupt geht...
wäre dann zwar nicht des Rätzels lösung aber es würde funktionieren, hoffe ich.

AW: Excel Makro funktioniert unter Excel 2003 nich
18.10.2007 19:57:37
Ramses
Hallo
einfach mal probieren:
On Error Resume Next
vor die Fehlerzeile schreiben.
Gruss Rainer

Anzeige
AW: Excel Makro funktioniert unter Excel 2003 nich
19.10.2007 09:28:00
Dr.Hossa
Jap, das Funktioniert es läuft einwandfrei, vielleicht nicht die schöneste Lösung, das sie das Problem nicht erklärt, aber erstmal die effektivste.
Danke und schönes Wochenende

AW: Excel Makro funktioniert unter Excel 2003 nich
18.10.2007 09:54:43
ChrisL
Hallo Herr Dr.
Wollte eben anfangen Select entfernen und zufällig (im office-lösungen-forum bin ich normalerweise nicht unterwegs) entdecke ich, dass sich schon jemand die Mühe gemacht hat. Wäre doch eine echte Zeitverschwendung gewesen und darum ist es unartig cross-zu-posten ;-)
http://www.office-loesung.de/ftopic181769_0_0_asc.php
Excel 2003 habe ich leider nicht, aber Code aufräumen war schon die halbe Miete. Ein Schuss ins Blaue meinerseits wäre das Blatt zu definieren.
Dim LastRowEWB1 As Long
Dim WS As Worksheet
Set WS = Worksheets("Tabelle1")
LastRowEWB1 = LastRowEWB + 4
With WS
.Range(Selection, Selection.End(xlDown)).Copy Destination:=.Range("A" & LastRowEWB1)
End With
Gruss
Chris
Anzeige

309 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige