Ich hatte kürzlich folgende Herausforderung zu lösen:
In einer Excel Tabelle waren sowohl Zellen als auch Textfelder mit einem Inhalt vorhanden.
Die Inhalte der Textfelder konnten nur durch doppelklicken auf das Textfeld ausgewählt bzw. kopiert werden.
Das Ziel war es den Inhalt aller Textfelder ebenfalls in Zellen zu extrahieren.
Nach einer kurzen Google Suche hatte ich auch gleich etwas passendes gefunden:
Private Sub CommandButton1_Click()
Tabelle1.Shapes("Text Box 1").Select
Tabelle2.Cells(1, 1) = Selection.Characters.Text
End Sub
Leider tauchte gleich das nächste Problem auf denn in der Beispieldatei die ich bekommen habe waren drei Textfelder enthalten. Das erste Textfeld hatte den Namen „Text Box 1“, das zweite und dritte Textfeld aber den identischen Namen „Text Box 3“. Scheinbar war das beim Export aus irgendeinem Programm zustande gekommen.
Mit Hilfe einiger weiterer Codeschnipsel bin ich dann schlussendlich zu einem fürs Erste recht brauchbaren Ergebnis gekommen. Mittels einer Schleife werden alle Textfelder (Shapes) bei denen der Name (in den ersten 4 Stellen) „Text“ enthält durchgelaufen und der Text daraus extrahiert.
Das passiert durch diesen Befehl: ShapeText = Shape.TextFrame.Characters.Text
Es gibt nun verschiedene Möglichkeiten den extrahierten Text weiter zu verarbeiten, man könnte ihn in eine zweite Tabelle schreiben – ich habe mich aus Kontrollzwecken dafür entschieden den Inhalt versetzt neben dem Textfeld in eine Spalte zu extrahieren. Dies ist mir wie folgt gelungen:
Mittels „ShapeBottomRight = Shape.BottomRightCell.Address“ wird die rechte untere Ecke des Textfelds ermittelt und anschließend ausgewählt „ActiveSheet.Range(ShapeBottomRight).Select“.
Danach wird über den Befehl „ActiveCell.Offset(rowOffset:=0, columnOffset:=2).Select“ definiert, dass die Zelle daneben ausgewählt wird und zwar 0 Zeilen darunter und 2 Spalten daneben. Dies lässt sich natürlich entsprechend anpassen.
Schlussendlich wird mit „ActiveCell.Value = ShapeText“ der Wert des jeweiligen Textfelds in die ausgewählte Zelle geschrieben.
'http://www.logicwurks.com/CodeExamplePages/ELoopThroughPictures.html
'https://msdn.microsoft.com/de-de/library/office/ff835842.aspx
'http://stackoverflow.com/questions/6262743/convert-cells1-1-into-a1-and-vice-versa
Sub LoopThroughPictures()
Dim Shape As Shape
For Each Shape In ActiveSheet.Shapes
If Left(Shape.Name, 4) = "Text" Then
Shape.Select
Debug.Print Shape.ID
Debug.Print Shape.Name
Debug.Print Shape.TextFrame.Characters.Text
Debug.Print Shape.Left
Debug.Print Shape.Top
Debug.Print Shape.BottomRightCell.Address
Debug.Print Shape.TopLeftCell.Address
ShapeID = Shape.ID
ShapeName = Shape.Name
ShapeText = Shape.TextFrame.Characters.Text
ShapeTopLeft = Shape.TopLeftCell.Address
ShapeBottomRight = Shape.BottomRightCell.Address
'https://support.microsoft.com/de-de/kb/291308
ActiveSheet.Range(ShapeBottomRight).Select
VarActiveRange = ActiveSheet.Range(ShapeBottomRight)
'MsgBox Range(ShapeBottomRight).Row & ", " & Range(ShapeBottomRight).Column
ActiveCell.Offset(rowOffset:=0, columnOffset:=2).Select
ActiveCell.Value = ShapeText
'Shape.Delete
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Range("A1").Select
End If
Next
End Sub
Ich bin nicht wirklich ein begnadeter VBA Spezialist sondern mehr ein „Codeschnipsel-Verwurstler“.
Man könnte das sicher eleganter oder einfacher machen, aber für mich hat es seinen Zweck erfüllt.