Beiträge

02.08.2016

Unterschiedliche Textfelder in Word aus Excel befüllen...

Ein einfaches Beispiel - unterschiedliche Textfelder in einem Word Dokument füllen mit Daten aus Excel.

A simple example - different text fields in a Word document, fill it with data from Excel.

Hier noch eine Beispieldatei / Here's a sample file:
Unterschiedliche Textfelder in Word aus Excel befüllen...[ZIP 100 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 02.08.2016
' Purpose   : Word - Datei öffnen, verschiedene Textfelder befüllen...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim strPathFile1 As String
    Dim strPathFile As String
    Dim strBookmark As String
    Dim objWDDocV As Object
    Dim objWDDoc As Object
    Dim objWDApp As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Pfad und Dateiname der WordVORLAGE. Diese ist im selben Ordner
    ' wie die Exceldatei mit dem Code
    strPathFile1 = ThisWorkbook.Path & Application.PathSeparator & _
        "Textfelder_befuellen_aus_Excel.dotx"
    ' Pfad und Dateiname der Worddatei. Diese ist im selben Ordner
    ' wie die Exceldatei mit dem Code
    strPathFile = ThisWorkbook.Path & Application.PathSeparator & _
        "Textfelder_befuellen_aus_Excel.docx"
    ' Die Wordapplikation sichtbar starten
    Set objWDApp = OffApp("Word", False)
    If Not objWDApp Is Nothing Then
        ' Worddatei öffnen und auf Objektvariable festlegen
        Set objWDDoc = objWDApp.Documents.Open(strPathFile, , True)
        ' Worddatei aus Vorlage öffnen und auf Objektvariable festlegen
        Set objWDDocV = objWDApp.Documents.Add(Template:=strPathFile1)
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier das Worddokument
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With objWDDoc
            .FormFields("Text1").Result = "Text1"
            .TextBox1.Text = "Text2"
            .ContentControls(1).Range.Text = "Text3"
            .ContentControls(2).Range.Text = "Text4"
            .Shapes("Text Box 1").TextFrame.TextRange.Text = "Text5"
        End With
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier das Worddokument, das aus der Vorlage erstellt wurde
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With objWDDocV
            .FormFields("Text1").Result = "Text1"
            .TextBox1.Text = "Text2"
            .ContentControls(1).Range.Text = "Text3"
            .ContentControls(2).Range.Text = "Text4"
            .Shapes("Text Box 1").TextFrame.TextRange.Text = "Text5"
        End With
    End If
    ' Die folgende Codezeile KANN raus, WENN die Datei dann z. B.
    ' gespeichert und geschlossen wird, also ein kompletter
    ' Durchgang gemacht wird
    ' IN UNSEREM BEISPIEL HIER NATÜRLICH NICHT!
    objWDApp.Visible = True
Fin:
    ' Objektvariablen zurücksetzen
    Set objWDDocV = Nothing
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 02.08.2016
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            objApp.Visible = blnVisible
    End Select
    Set OffApp = objApp
    Set objApp = Nothing
End Function

18.01.2016

Outlook - Ordner im Postein- und Postausgang erstellen...

Outlook - Ordner im Posteingang und Postausgang erstellen. Wie geht das?

Create a folder in your Inbox and Outbox - Outlook. How does it work?

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 18.01.2016
' Purpose   : Outlook - Ordner unter Postein- und Postausgang erstellen...
'--------------------------------------------------------------------------
Sub Main()
    Dim objNewFolder As Object
    Dim varFolder As Variant
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objName As Object
    Dim blnTMP As Boolean
    On Error GoTo Fin
    varFolder = Application.InputBox("Ordnername?", Type:=2)
    If Not varFolder = False And Trim(varFolder) <> "" Then
        Set objOutApp = CreateObject("Outlook.Application")
        Set objName = objOutApp.GetNamespace("MAPI")
        ' 6 = olFolderInbox
        ' 4 = olFolderOutbox
        On Error Resume Next
        Set objFolder = objName.GetDefaultFolder(6)
        Set objNewFolder = objFolder.Folders.Add(varFolder)
        If Err.Number = 440 Then blnTMP = True
        Err.Clear
        On Error GoTo Fin
        Set objFolder = objName.GetDefaultFolder(4)
        Set objNewFolder = objFolder.Folders.Add(varFolder)
    End If
Fin:
    Select Case Err.Number
        Case 440
            MsgBox "Ordner bereits vorhanden!"
        Case 0
        Case Else
            MsgBox "Fehler: " & Err.Number & " " & Err.Description
    End Select
    Set objNewFolder = Nothing
    Set objFolder = Nothing
    Set objName = Nothing
    Set objOutApp = Nothing
End Sub
' Nachfolgend die Elemente bzw. Konstanten von "OlDefaultFolders"
' Entnommen aus Objektkatalog (F2 im VBA-Editor) in Outlook 2010
'Const olFolderCalendar = 9
'Const olFolderConflicts = 19 (&H13)
'Const olFolderContacts = 10
'Const olFolderDeletedItems = 3
'Const olFolderDrafts = 16 (&H10)
'Const olFolderInbox = 6
'Const olFolderJournal = 11
'Const olFolderJunk = 23 (&H17)
'Const olFolderLocalFailures = 21 (&H15)
'Const olFolderManagedEmail = 29 (&H1D)
'Const olFolderNotes = 12
'Const olFolderOutbox = 4
'Const olFolderRssFeeds = 25 (&H19)
'Const olFolderSentMail = 5
'Const olFolderServerFailures = 22 (&H16)
'Const olFolderSuggestedContacts = 30 (&H1E)
'Const olFolderSyncIssues = 20 (&H14)
'Const olFolderTasks = 13
'Const olFolderToDo = 28 (&H1C)
'Const olPublicFoldersAllPublicFolders = 18 (&H12)

04.01.2016

UserForm - Datum - Filtern - als PDF speichern...

In Spalte A steht fortlaufend das Datum. Dies soll über eine UserForm gefiltert und als PDF gespeichert werden.

In column A continuously is the date. This should be filtered through a UserForm and saved as a PDF.

Hier noch eine Beispieldatei / Here's a sample file:
UserForm - Datum - Filtern - als PDF speichern...[XLSM 60 KB]

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : UserForm_Activate
' Author    : © Case (Ralf Stolzenburg)
' Date      : 04.01.2016
' Purpose   : Bereich - Datum - Filtern - PDF speichern...
'--------------------------------------------------------------------------
Private Sub UserForm_Activate()
    ' Tabelle1 Spalte A in Combobox schreiben
    ComboBox1.List = Tabelle1.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ' Inhalt ComboBox2 = ComboBox1
    ComboBox2.List = ComboBox1.List
    ' Eintrag in ComboBox1 komplett markieren - ersten Eintrag anzeigen
    With ComboBox1
        .ListIndex = 0
        .SetFocus
        .SelStart = 0
        .SelLength = Len(ComboBox1)
    End With
    ' 16ten Eintrag von ComboBox2 anzeigen (Zählung beginnt bei 0)
    ComboBox2.ListIndex = 15
End Sub
Private Sub CommandButton1_Click()
    ' Variablendeklaration
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Wenn ComboBox1 oder 2 leer ist - Meldung ausgeben
    If Me.ComboBox1.Text = "" Or Me.ComboBox2.Text = "" Then
        If Me.ComboBox1.Text = "" Then
            MsgBox "Startdatum angeben!"
            Me.ComboBox1.SetFocus
        Else
            MsgBox "Enddatum angeben!"
            ComboBox2.SetFocus
        End If
    Else
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier Tabelle1 = der CodeName der Tabelle
        ' Im VBA-Editor der Name VOR der Klammer - Tabelle1 (Tabelle1)
        ' im englischen Excel in der Regel Sheet1
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With Tabelle1
            ' Filtern und als PDF auf dem Desktop speichern
            .Range("A1").AutoFilter Field:=1, _
            Criteria1:=">=" & CDbl(DateValue(ComboBox1)), _
            Operator:=xlAnd, Criteria2:="<=" & CDbl(DateValue(ComboBox2))
            .ExportAsFixedFormat 0, Environ("UserProfile") & _
                "\Desktop\" & Left(ThisWorkbook.Name, _
                (InStrRev(ThisWorkbook.Name, ".") - 1)) & _
                Format(Now, "_DD.MM.YYYY"), , , , , , False
            ' Wenn Autofilter und gefiltert dann alle Daten zeigen
            If .AutoFilterMode And .FilterMode Then .ShowAllData
            ' Autofilter löschen
            .Rows.AutoFilter
            ' Seitenumbruchlinien ausblenden
            .DisplayAutomaticPageBreaks = False
        End With
    End If
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
    ' und die Fehlerbeschreibung aus
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub ComboBox2_DropButtonClick()
    ' Eintrag in ComboBox2 komplett markieren
    With ComboBox2
        .SetFocus
        .SelStart = 0
        .SelLength = Len(ComboBox2)
    End With
End Sub
Private Sub CommandButton2_Click()
    ' UserForm entladen
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' Schliessen über das "x" unterbinden
    If CloseMode = 0 Then Cancel = True
End Sub

27.08.2015

Geschlossene Dateien - Range und Summe bestimmter Zellen...

Geschlossene Dateien. Zellen werden über ein Array ausgelesen - inklusive Unterordner (optional). Bestimmte Zellen werden summiert. Nur Dateien die einem bestimmten Muster folgen, werden eingelesen. In diesem Beispiel - kein "eta" im Dateiname. Die Summe wird über "ExecuteExcel4Macro" realisiert.

Closed files. Cells are read on an array - including subfolders (optional). Certain cells are summed. Only files that follow a certain pattern are read. In this example - no "eta" in the File Name. The sum will be implemented via "ExecuteExcel4Macro".

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - Range und Summe bestimmter Zellen...[ZIP 900 KB]

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Tabelle1"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Werte"
' Diese Zellen werden Summiert
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read_1
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    Dim objShell As Object
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        blnUpdate = .AskToUpdateLinks
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Wenn Du einen Ordnerauswahldialog möchtest
    'Set objShell = CreateObject("Shell.Application")
    'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
    'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
    'strDir = varDir.Self.Path
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    Set objDir = objFSO.GetFolder(strDir)
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier strSheetZ
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With ThisWorkbook.Worksheets(strSheetZ)
        ' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
        .Rows("2:" & .Rows.Count).ClearContents
        ' Mit Unterordner
        dirInfo objDir, "*.xls*", True
        ' Ohne Unterordner
        'dirInfo objDir, "*.xls*"
        ' Formeln entfernen - Werte bleiben erhalten
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = blnUpdate
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : dirInfo
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
' Rekursive Sub mit Array - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    ' Variablendeklaration
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim arrCell As Variant
    Dim intTMP As Integer
    Dim varTMP As Variant
    ' Weitere Zellen nach gleichem Muster in das Array einfügen
    arrCell = Array("A1", "C1", "E2", "H8", "I8", _
        "H16", "I16", "H24", "I24", "H32", "I32", "C8", _
        "D8", "C16", "D16", "C24", "D24", "C32", "D32")
    ' Alle Dateien im vorgegebenen Ordner
    For Each varTMP In objCurrentDir.Files
        ' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
        ' Falls im gleichen Ordner und ist KEINE temporäre Datei
        ' Dateiname mit "eta" im Namen werden NICHT eingelesen!!!!!
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            If Not varTMP.Name Like "*eta*" Then
                ' Der Code bezieht sich auf ein bestimmtes Objekt
                ' Hier strSheetZ
                ' Alles was sich auf dieses "With" bezieht
                ' MUSS mit einem Punkt beginnen
                With ThisWorkbook.Worksheets(strSheetZ)
                    ' Letzte Zeile bezogen auf Spalte A plus 1
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                        .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                    ' Schleife über alle Zellen des Arrays
                    For intTMP = LBound(arrCell) To UBound(arrCell)
                        ' Hier würde jetzt noch der Dateiname mit Pfad
                        ' in die nächste freie Spalte geschrieben
                        '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
                        ' Hier würde jetzt noch der Dateiname
                        ' in die nächste freie Spalte geschrieben
                        '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
                        ' Werte über Formel holen, Tabellenblatt über "Const..."
                        ' oben definiert, Zelle über Array. Formel in Spalte A folgende...
                        strFormula = "'" & Mid(varTMP.Path, 1, InStrRev(varTMP.Path, "\")) & _
                            "[" & Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & strSheetQ & "'!"
                        .Cells(lngLastRow, intTMP + 1).Formula = "=" & strFormula & arrCell(intTMP)
                    Next intTMP
                    .Cells(lngLastRow, 20).Value = ExecuteExcel4Macro(strFormula & "R18C6") + _
                        ExecuteExcel4Macro(strFormula & "R26C6") + _
                        ExecuteExcel4Macro(strFormula & "R34C6")
                    .Cells(lngLastRow, 21).Value = ExecuteExcel4Macro(strFormula & "R21C6") + _
                        ExecuteExcel4Macro(strFormula & "R29C6") + _
                        ExecuteExcel4Macro(strFormula & "R37C6")
                End With
            End If
        End If
    Next varTMP
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

22.08.2015

Word - UserForm - ComboBox - TextBoxen - Daten aus Excel ziehen...

Eine Userform in Word. Die Combobox wird mit Daten aus Excel gefüllt. Bei Auswahl eines Namens werden die Textboxen mit den zugehörigen Daten befüllt. Die Exceldatei wird zu Beginn ausgeblendet geöffnet und beendet, wenn die Userform geschlossen wird. Die Word- und Exceldatei müssen im gleichen Verzeichnis sein.

A UserForm in Word. The combo box is filled with data from Excel. When you select a name, the text boxes are filled with the corresponding data. The Excel file is opened hidden at the start and ends when the UserForm is closed. The Word and Excel file must be in the same directory.

Hier noch eine Beispieldatei / Here's a sample file:
Word - UserForm - ComboBox - TextBoxen - Daten aus Excel ziehen...[ZIP 35 KB]

' Variablendeklaration erforderlich
Option Explicit
' Konstanten - da Late Binding also KEIN Verweis auf Excelbibliothek
Const xlFormulas = -4123
Const xlColumns = 2
Const xlUp = -4162
Const xlWhole = 1
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : UserForm_Initialize
' Author    : © Case (Ralf Stolzenburg)
' Date      : 22.08.2015
' Purpose   : Excel öffnen, Daten aus Adressliste per Find ziehen...
'--------------------------------------------------------------------------
' Variablendeklaration ausserhalb - weil auch andere Prozeduren zugreifen
    Dim lngLastRow As Long
    Dim objSheet As Object
    Dim blnTMP As Boolean
    Dim objExel As Object
Private Sub UserForm_Initialize()
    ' Variablendeklaration
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Exceldatei ausgeblendet öffnen
    Set objExel = GetObject(ThisDocument.Path & "\AdressListe.xls")
    ' Zugriff auf das erste Tabellenblatt
    Set objSheet = objExel.Worksheets(1)
    ' Oder mit Namen
    'Set objSheet = objExel.WorkSheets("Adressen")
    With objSheet
        ' letzte belegte Zeile im Excelsheet in Spalte A ermitteln
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ComboBox1.Clear
        ' Erster Eintrag in der Combobox
        ComboBox1.AddItem ("Auswahl...")
        ' Schleife um die Combobox zu befüllen
        For lngTMP = 2 To lngLastRow
            ComboBox1.AddItem (.Range("A" & lngTMP))
        Next lngTMP
        ' Combobox auf ersten Eintrag setzen
        ComboBox1.ListIndex = 0
    End With
    blnTMP = True
Fin:
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub ComboBox1_Change()
    ' Variablendeklaration
    Dim lngTMP As Long
    Dim lngRow As Long
    On Error GoTo Fin
    ' Da schon beim befüllen der Combobox das Change-Event ausgeführt
    ' wird - hier unterbunden mit einer Boolean-Variablen
    If blnTMP Then
        ' Wenn nicht der erste Eintrag angezeigt wird dann...
        If ComboBox1.ListIndex > 0 Then
            ' Finde in Excel die Zeile mit dem Inhalt von Combobox1
            lngRow = objSheet.Range("A2:A" & lngLastRow).Find _
                (ComboBox1.Value, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlColumns).Row
            ' Befülle die Textboxen mit den korrespondierenden Werten
            For lngTMP = 1 To 4
                Me.Controls("TextBox" & lngTMP).Text = _
                    objSheet.Cells(lngRow, lngTMP + 1).Text
            Next lngTMP
        Else
            ' Sonst also wenn Auswahl... bzw. Listindex <=0 dann Textboxen leeren
            For lngTMP = 1 To 4
                Me.Controls("TextBox" & lngTMP).Text = ""
            Next lngTMP
        End If
    End If
Fin:
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub CommandButton1_Click()
    ' Userform beenden
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' Wenn NICHT das "x" geklickt wurde dann...
    If CloseMode <> 0 Then
        ' Excel schliessen
        objExel.Close False
        ' Objektvariable leeren
        Set objSheet = Nothing
        Set objExel = Nothing
    Else
        ' Sonst mache nichts bzw. breche das beenden ab
        Cancel = True
    End If
End Sub

14.07.2014

Word öffnen, Range formatiert kopieren, nicht als Tabelle...

Einen Range (z. B. A1:A10) nach Word kopieren. Schriftformate unverändert übernehmen. Es darf aber nicht als Tabelle eingefügt werden bzw. muss als Text umgewandelt werden.

A range (eg A1:A10) copy to Word. Font formats take over unchanged. But it must not be inserted as a table or must be converted as text.

Hier noch eine Beispieldatei / Here's a sample file:
Word öffnen, Range formatiert kopieren, nicht als Tabelle...[ZIP 20 KB]

Option Explicit
' Konstante für Parameter Umwandlung der Tabelle in Word als Text
' Es gibt:
' Const wdSeparateByDefaultListSeparator = 3
' Const wdSeparateByCommas = 2
' Const wdSeparateByTabs = 1
Const wdSeparateByParagraphs = 0
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Word öffnen, Range formatiert kopieren, nicht als Tabelle...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim strBookmark As String
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Die Wordapplikation sichtbar starten
    Set objWDApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objWDApp Is Nothing Then
        ' Name der Textmarke
        strBookmark = "Test"
        ' Ein neues Worddokument erstellen
        Set objWDDoc = objWDApp.Documents.Add
        ' Diese Zeile ist eigentlich blödsinnig, denn in einem
        ' neuen Dokument kann keine Textmarke / Bookmark sein
        ' Aber man sieht, wie auf eine Textmarke geprüft werden kann
        ' Und wie eine Textmarke hinzugefügt wird
        If Not objWDDoc.Bookmarks.Exists(strBookmark) = True Then
            objWDDoc.Bookmarks.Add Name:=strBookmark
            ' Bereich der kopiert werden soll
            Tabelle1.Range("A1:A10").Copy
            ' Aus dem Objektkatalog von Word im VBA-Editor (F2)
            ' Sub PasteExcelTable(LinkedToExcel As Boolean,
            ' WordFormatting As Boolean, RTF As Boolean)
            objWDDoc.Bookmarks(strBookmark).Range.PasteExcelTable False, False, False
            ' Umwandlen der Tabelle zu Text
            objWDDoc.Tables(1).Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
                NestedTables:=True
        End If
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module3
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function