Mit Makro Adresse nach Word kopieren

Option Explicit

Const ExcelDatei = "X:\Test\Test.xls"  
Const ExcelTabelle = "Tabelle1"  

Const AdrName = "A"         'Excel-Spalte Namen  
Const AdrStr = "B"          'Excel-Spalte Straße  
Const AdrPlz = "C"          'Excel-Spalte Postleitzahl  
Const AdrOrt = "D"          'Excel-Spalte Ort  

Const xlWhole = 1           'Excel-Konstanten  
Const xlValues = -4163

Sub GetAddress()
    Dim Search As String, Text As String
    
    If CreateObject("Scripting.FileSystemObject").FileExists(ExcelDatei) = False Then  
        MsgBox "Die Excel-Datei wurde nicht gefunden!", vbExclamation, "Fehler"  
        Exit Sub
    End If

    Search = InputBox("Bitte einen Namen eingeben", "Suchen")  
    
    If Search = "" Then Exit Sub  
    
    Text = GetExcelDaten(Search)
    
    If Text = "" Then  
        MsgBox "Der Name wurde nicht gefunden!", vbInformation, "Suchergebnis"  
    Else
        Selection.TypeText Text
    End If
End Sub

Private Function GetExcelDaten(ByRef Search) As String
    Dim Wks As Object, Found As Object
    
    Set Wks = GetObject(ExcelDatei).Sheets(ExcelTabelle)
    
    Set Found = Wks.Columns(AdrName).Find(Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    
    If Not Found Is Nothing Then
        With Wks.Rows(Found.Row)
            GetExcelDaten = .Columns(AdrName) & vbCrLf & vbCrLf & _
                            .Columns(AdrStr) & vbCrLf & _
                            .Columns(AdrPlz) & " " & .Columns(AdrOrt) & vbCrLf & vbCrLf  
        End With
    End If
    
    Application.DisplayAlerts = False
    GetObject(ExcelDatei).Close True
    Application.DisplayAlerts = True
End Function

    If CreateObject("Scripting.FileSystemObject").FileExists(ExcelDatei) Then  
        MsgBox "Datei existiert!"  
    Else
        MsgBox "Datei existiert leider nicht!"  
    End If
    
    Exit Function

Option Explicit

Const ExcelDatei = "D:\Projekte\Makro\test.xls"  
Const ExcelSheet = "Tabelle1"  

Const AdrName = "A"         'Excel-Spalte Namen  
Const AdrStr = "B"          'Excel-Spalte Straße  
Const AdrPlz = "C"          'Excel-Spalte Postleitzahl  
Const AdrOrt = "D"          'Excel-Spalte Ort  

Const xlWhole = 1           'Excel-Konstanten  
Const xlValues = -4163

Const Zeile1 = 4            'Adresse in dieser Zeile einfügen  

Sub GetAddress()
    Dim Search As String, Text As Variant, i As Long
    
    If CreateObject("Scripting.FileSystemObject").FileExists(ExcelDatei) = False Then  
        MsgBox "Die Excel-Datei wurde nicht gefunden!", vbExclamation, "Fehler"  
        Exit Sub
    End If
    
    Search = InputBox("Bitte einen Namen eingeben", "Suchen")  
    
    If Search = "" Then Exit Sub  
    
    Text = GetExcelDaten(Search)
    
    If IsArray(Text) Then
        With ActiveDocument
            For i = .Paragraphs.Count To Zeile1 - 1
                .Paragraphs.Add
            Next
            For i = 0 To UBound(Text)
                .Paragraphs(Zeile1 + i).Range.Text = Text(i) & vbCrLf
            Next
            For i = 0 To UBound(Text)
                .Paragraphs(Zeile1 + i).Alignment = wdAlignParagraphLeft  'Oder  wdAlignParagraphRight    
            Next
        End With
    Else
        MsgBox "Der Name wurde nicht gefunden!", vbInformation, "Suchergebnis"  
    End If
End Sub

Private Function GetExcelDaten(ByRef Search) As Variant
    Dim Wks As Object, Found As Object, Text As Variant
  
    Set Wks = GetObject(ExcelDatei).Sheets(ExcelSheet)
    
    Set Found = Wks.Columns(AdrName).Find(Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    
    If Not Found Is Nothing Then
        With Wks.Rows(Found.Row)
            GetExcelDaten = Array(.Columns(AdrName).Text, "", .Columns(AdrStr).Text, _  
                                  .Columns(AdrPlz).Text & " " & .Columns(AdrOrt).Text)  
        End With
    End If
    
    With Application
        .DisplayAlerts = False:  GetObject(ExcelDatei).Close True:  .DisplayAlerts = True
    End With
End Function