Macroproblem unter 2013
14.07.2013 15:57:57
Benedikt
nachfolgendes Macro erledigt seinen Job unter 2007 und 2010 einwandfrei.
Jetzt habe ich 2013 aufgespielt und wie bei jedem Versionswechsel klemmt das eine oder andere. Das Macro fügt Text und Beträge aus einem Kalkulationsblatt (separate Datei)in das Offertblahtt ein.
Unter Office 2013 fügt das Macro beim ersten ausführen den Text nicht mehr in die vorgegebenen Zellen sondern überschreibt einen Teil der Adresse.Ab dem zweiten Textblock funktioniert es. Mit F8, schrittweise ausführen funktioniert es aber auch beim ersten mal. In der Annahme das die Geschwindigkeit unter 2013 das Problem sein könnte, habe ich versucht Application.Wait(Now + TimeValue("0:00:1"))einzubauen.
Aber entweder stelle ich mich wieder ganz clever an und habe es an der falschen Stelle eingesetzt, oder ich bin damit komplett auf dem Holzweg.
Ich bin sehr Dankbar wenn Ihr mir helfen könnt. Da es mehrere grosse Dateien sind ist ein Upload nicht möglich. Im Anhang aber eine Datei welche das Resultat zeigt.
https://www.herber.de/bbs/user/86347.xlsm
Vielen herzlichen Dank und einen schönen Sommertag. Grüsse Benedikt
Option Explicit
Const cstrRange As String = "C20:C2000"
Public rng As Range, lngRow As Long, Kalkblatt As Worksheet, neu As Long, Spalte As Long
Public NameMappe As String
Public NummerMappe As Variant
Function Freien_Platz_suchen()
With Workbooks("Tempoff.xlsm").Worksheets("Offerte")
For Each rng In .Range(cstrRange)
If rng = "" Then
If rng.Offset(1, 0) = "" And Not Intersect(rng.Offset(1, 0), .Range(cstrRange)) Is Nothing Then
If rng.Offset(2, 0) = "" And Not Intersect(rng.Offset(2, 0), .Range(cstrRange)) Is Nothing Then
lngRow = rng.Row + 1
Exit For
End If
End If
End If
Next
End With
End Function
Public Function MappeCopy()
NameMappe = Left(Range("C8").Value, 15)
NummerMappe = Workbooks("Tempoff.xlsm").Sheets.Count
NummerMappe = NummerMappe + 1
ActiveSheet.Copy After:=Workbooks("Tempoff.xlsm").Sheets(3)
ActiveSheet.Name = NummerMappe & " " & NameMappe
Sheets("Offerte").Select
End Function
Function Text_einfügen()With Workbooks("Tempoff.xlsm").Worksheets("Offerte").Cells(lngRow, Spalte)
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End Function Sub Test()
Freien_Platz_suchen
Application.ScreenUpdating = False
'Titel kopieren
lngRow = lngRow + 1
If lngRow > 0 Then Sheets("Hugo").Range("C8").Copy
Spalte = 3
Text_einfügen
'Nummerierung
Workbooks("Tempoff.xlsm").Worksheets("Offerte").Activate
ActiveCell.Offset(0, -1) = Int(Application.WorksheetFunction.Max(Range(Cells(1, 2), Cells(ActiveCell.Row, 2)))) + 1
Selection.Font.Bold = True
Workbooks("Tempkalk.xlsm").Worksheets("Hugo").Activate
'Text einfügen
Freien_Platz_suchen
lngRow = lngRow
If lngRow > 0 Then Sheets("Hugo").Range("C9:C21").Copy
Text_einfügen
'Totalkopieren
Freien_Platz_suchen
lngRow = rng.Row - 1
If lngRow > 0 Then Sheets("Hugo").Range("I8:K8").Copy
Spalte = 8
Text_einfügen
'Arbeitsblatt drucken
Workbooks("Tempkalk.xlsm").Worksheets("Hugo").Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1
'Arbeitsblatt Hugo in Offerte kopieren
MappeCopy
'Übergabe Auswertung an Titelblatt
Workbooks("Tempkalk.xlsm").Worksheets("Hugo").Activate
Range("O4:AC4").Select
Selection.Copy
Workbooks("Tempoff.xlsm").Worksheets("Titel").Activate
Range("A26").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Rows("26:26").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("A27:M27").Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With
Range("C27:M27").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
Selection.NumberFormat = "0.00"
End With
Range("A100").Select
Sheets("Offerte").Select
ActiveWorkbook.Save
Windows("Tempkalk.xlsm").Activate
Application.ScreenUpdating = True
MsgBox "Kalkulation I.O "
End Sub