Hab die Datei jetzt mal ein wenig verkleinert und vom Logo
befreit hier hochgeladen:
http://www.hostarea.de/server-07/Juli-fc8747a008.xls
Ausserdem sind in dem File nur 3 Etiketten drinn, um einen
Eindruck zu gewinnen!
Hi Mike,
Alt+F11, Einfügen–Modul, Code reinkopieren, Editor offenlassen.
Dann wechselst du zu Excel, Ansicht–Symbolleisten–Formular, da ziehst du dir eine Befehlsschaltfläche (das graue Kästchen) aufs Blatt, automatisch wirst du gefragt welches makro du zuweisen willst, du wählst Makro1, dann Ok, dann Klick auf beliebige zelle,
Mit dem Klick auf den Button startest du das Makro.
Ich kenne ja deine Etikettenmaße nicht, weiß also nicht wo welches genau hin soll.
Verändere einfach erstmal die Zahlen (Punkt als Komma benutzten!) im folgenden Codeteil und starte dann das Makro. In gewisser Weise erklärt er sich selbst.
For S = 1 To .Count
.Item(S).Top = CentimetersToPoints(3.5)
.Item(S).Left = CentimetersToPoints(6) + (S - 1) \* CentimetersToPoints(6)
.Item(S).Height = CentimetersToPoints(10)
.Item(S).Width = CentimetersToPoints(2.5)
Next S
Wenn du nicht klarkommst brauche ich alle Infos von deinen Etiketten.
Gruß
Reinhard
Option Explicit
'
Sub Makro1()
Dim Spa As Long, appWord As Object, S As Integer
On Error GoTo Ende
Set appWord = CreateObject("Word.Application")
appWord.Visible = True
appWord.Documents.Add
For Spa = 1 To 5 Step 2
Range(Cells(1, Spa), Cells(35, Spa)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
appWord.Selection.Paste
Next Spa
Application.CutCopyMode = False
With appWord.ActiveDocument.InlineShapes
For S = .Count To 1 Step -1
.Item(S).ConvertToShape
Next S
End With
DoEvents
With appWord.ActiveDocument.Shapes
For S = 1 To .Count
.Item(S).Top = CentimetersToPoints(3.5)
.Item(S).Left = CentimetersToPoints(6) + (S - 1) \* CentimetersToPoints(6)
.Item(S).Height = CentimetersToPoints(10)
.Item(S).Width = CentimetersToPoints(2.5)
Next S
End With
appWord.ActiveDocument.PrintPreview
Set appWord = Nothing
Exit Sub
Ende:
Application.DisplayAlerts = False
appWord.Quit
Application.DisplayAlerts = True
Set appWord = Nothing
End Sub
(