VBA-Forum - Das Forum zu Microsoft VBA

VBA Excel VBA Word VBA Access VBA VBScript VB C# Objective-C C++ SQL JAVA VBA (English) Jobs Übersicht

Thema	Datum	Von Nutzer	Rating	Antwort
Word Userform Excel-Abfragen zusammenfassen	23.10.2015 20:20:19	xtoph

Ansicht des Beitrags:

Von:
xtoph

Datum:
23.10.2015 20:20:19

Views:
1567

Rating:

Antwort:

Thema:
Word Userform Excel-Abfragen zusammenfassen

Hallo,

ich hoffe, Ihr könnt mir helfen. Und zwar habe ich mir eine Word-Briefvorlage gebastelt, welche beim Start Adressen aus einer Exceldatei abfragt und die Einträge an den entsprechenden Textmarken platziert. Soweit so gut. Jetzt wollte ich aus der selben Datei weitere Abfragen aus den unterschiedlichen Sheets integrieren. Dies funktioniert auch jedes für sich gut. Mein Problem ist, das alle Abfragen mittels der gleichen Userform gemacht werden sollen und die Einträge in die selbe Word-Vorlage ausgegeben werden soll. Kurz um kann mir jemand dabei behilflich sein aus nachfolgenden 4 Codes einen Code zu machen???

1. ListBox1

Option Explicit
Private Const sAdressDatei As String = _
     "adress.xlsx"

Private Sub CommandButton1_Click()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     If ListBox1.ListIndex >= 0 Then
    
         Set oExcelApp = CreateObject("Excel.Application")
         Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
         lZeile = 2
         With oExcelWorkbook.sheets("adress")
             Do While .Cells(lZeile, 1) <> ""
                 If ListBox1.Text = CStr(.Cells(lZeile, 2).Value) Then
                     ActiveDocument.Bookmarks("Textmarke_Firma").Range.Text = _
                         CStr(.Cells(lZeile, 6).Value)
                     ActiveDocument.Bookmarks("Textmarke_Straße").Range.Text = _
                         CStr(.Cells(lZeile, 7).Value)
                     ActiveDocument.Bookmarks("Textmarke_Ort").Range.Text = _
                         CStr(.Cells(lZeile, 8).Value)
                     ActiveDocument.Bookmarks("Textmarke_PLZ").Range.Text = _
                         CStr(.Cells(lZeile, 9).Value)
                     ActiveDocument.Bookmarks("Textmarke_Land").Range.Text = _
                         CStr(.Cells(lZeile, 10).Value)
                     ActiveDocument.Bookmarks("Textmarke_Anrede").Range.Text = _
                         CStr(.Cells(lZeile, 14).Value)
                     ActiveDocument.Bookmarks("Textmarke_Person").Range.Text = _
                         CStr(.Cells(lZeile, 15).Value)
                     Exit Do
                 End If
                 lZeile = lZeile + 1
             Loop
         End With
       
         oExcelWorkbook.Close False
         oExcelApp.Quit
    
     Else
         MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
             vbInformation + vbOKOnly, "HINWEIS!"
         Exit Sub
     End If

   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
   Unload Me
End Sub

Private Sub CommandButton2_Click()
     Unload Me
End Sub

Private Sub Label1_Click()

End Sub

Private Sub ListBox1_Click()

End Sub

Private Sub UserForm_Initialize()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     Set oExcelApp = CreateObject("Excel.Application")
     Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
     ListBox1.Clear
     lZeile = 2
     With oExcelWorkbook.sheets("adress")
         Do While .Cells(lZeile, 1) <> ""
             ListBox1.AddItem CStr(.Cells(lZeile, 2).Value)
             lZeile = lZeile + 1
         Loop
     End With
       
     oExcelWorkbook.Close False
     oExcelApp.Quit
      
   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
End Sub

2. ComboBox 1

Option Explicit
Private Const sAdressDatei As String = _
     "adress.xlsx"

Private Sub CommandButton1_Click()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     If ComboBox1.ListIndex >= 0 Then
    
         Set oExcelApp = CreateObject("Excel.Application")
         Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
         lZeile = 2
         With oExcelWorkbook.sheets("firm")
             Do While .Cells(lZeile, 1) <> ""
                 If ComboBox1.Text = CStr(.Cells(lZeile, 2).Value) Then
                     ActiveDocument.Bookmarks("Textmarke_BezDatei").Range.Text = _
                         CStr(.Cells(lZeile, 3).Value)
                     ActiveDocument.Bookmarks("Textmarke_BezBetreff").Range.Text = _
                         CStr(.Cells(lZeile, 4).Value)
                     ActiveDocument.Bookmarks("Textmarke_Auftragsnummer").Range.Text = _
                         CStr(.Cells(lZeile, 5).Value)
                     Exit Do
                 End If
                 lZeile = lZeile + 1
             Loop
         End With
       
         oExcelWorkbook.Close False
         oExcelApp.Quit
    
     Else
         MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
             vbInformation + vbOKOnly, "HINWEIS!"
         Exit Sub
     End If

   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
   Unload Me
End Sub

Private Sub CommandButton2_Click()
     Unload Me
End Sub

Private Sub Label1_Click()

End Sub

Private Sub ComboBox1_Click()

End Sub

Private Sub Label3_Click()

End Sub

Private Sub UserForm_Initialize()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     Set oExcelApp = CreateObject("Excel.Application")
     Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
     ComboBox1.Clear
     lZeile = 2
     With oExcelWorkbook.sheets("firm")
         Do While .Cells(lZeile, 1) <> ""
             ComboBox1.AddItem CStr(.Cells(lZeile, 2).Value)
             lZeile = lZeile + 1
         Loop
     End With
       
     oExcelWorkbook.Close False
     oExcelApp.Quit
      
   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
End Sub
ComboBox2
Option Explicit
Private Const sAdressDatei As String = _
     "adress.xlsx"

Private Sub CommandButton1_Click()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     If ComboBox2.ListIndex >= 0 Then
    
         Set oExcelApp = CreateObject("Excel.Application")
         Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
         lZeile = 2
         With oExcelWorkbook.sheets("signature")
             Do While .Cells(lZeile, 1) <> ""
                 If ComboBox2.Text = CStr(.Cells(lZeile, 2).Value) Then
                     ActiveDocument.Bookmarks("Textmarke_Unterschrift1").Range.Text = _
                         CStr(.Cells(lZeile, 6).Value)
                     Exit Do
                 End If
                 lZeile = lZeile + 1
             Loop
         End With
       
         oExcelWorkbook.Close False
         oExcelApp.Quit
    
     Else
         MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
             vbInformation + vbOKOnly, "HINWEIS!"
         Exit Sub
     End If

   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
   Unload Me
End Sub

Private Sub CommandButton2_Click()
     Unload Me
End Sub


Private Sub UserForm_Initialize()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     Set oExcelApp = CreateObject("Excel.Application")
     Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
     ComboBox2.Clear
     lZeile = 2
     With oExcelWorkbook.sheets("signature")
         Do While .Cells(lZeile, 1) <> ""
             ComboBox2.AddItem CStr(.Cells(lZeile, 2).Value)
             lZeile = lZeile + 1
         Loop
     End With
       
     oExcelWorkbook.Close False
     oExcelApp.Quit
      
   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
End Sub

3. ComboBox2

Option Explicit
Private Const sAdressDatei As String = _
     "adress.xlsx"

Private Sub CommandButton1_Click()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     If ComboBox2.ListIndex >= 0 Then
    
         Set oExcelApp = CreateObject("Excel.Application")
         Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
         lZeile = 2
         With oExcelWorkbook.sheets("signature")
             Do While .Cells(lZeile, 1) <> ""
                 If ComboBox2.Text = CStr(.Cells(lZeile, 2).Value) Then
                     ActiveDocument.Bookmarks("Textmarke_Unterschrift1").Range.Text = _
                         CStr(.Cells(lZeile, 6).Value)
                     Exit Do
                 End If
                 lZeile = lZeile + 1
             Loop
         End With
       
         oExcelWorkbook.Close False
         oExcelApp.Quit
    
     Else
         MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
             vbInformation + vbOKOnly, "HINWEIS!"
         Exit Sub
     End If

   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
   Unload Me
End Sub

Private Sub CommandButton2_Click()
     Unload Me
End Sub


Private Sub UserForm_Initialize()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     Set oExcelApp = CreateObject("Excel.Application")
     Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
     ComboBox2.Clear
     lZeile = 2
     With oExcelWorkbook.sheets("signature")
         Do While .Cells(lZeile, 1) <> ""
             ComboBox2.AddItem CStr(.Cells(lZeile, 2).Value)
             lZeile = lZeile + 1
         Loop
     End With
       
     oExcelWorkbook.Close False
     oExcelApp.Quit
      
   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
End Sub

4. ComboBox3

Option Explicit
Private Const sAdressDatei As String = _
     "adress.xlsx"

Private Sub CommandButton1_Click()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     If ComboBox3.ListIndex >= 0 Then
    
         Set oExcelApp = CreateObject("Excel.Application")
         Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
         lZeile = 2
         With oExcelWorkbook.sheets("signature")
             Do While .Cells(lZeile, 1) <> ""
                 If ComboBox3.Text = CStr(.Cells(lZeile, 2).Value) Then
                     ActiveDocument.Bookmarks("Textmarke_Unterschrift2").Range.Text = _
                         CStr(.Cells(lZeile, 6).Value)
                     Exit Do
                 End If
                 lZeile = lZeile + 1
             Loop
         End With
       
         oExcelWorkbook.Close False
         oExcelApp.Quit
         
         Else
         MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
             vbInformation + vbOKOnly, "HINWEIS!"
         Exit Sub
    
     End If

   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
   Unload Me
End Sub

Private Sub CommandButton2_Click()
     Unload Me
End Sub


Private Sub UserForm_Initialize()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
  
     Set oExcelApp = CreateObject("Excel.Application")
     Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)
    
     ComboBox3.Clear
     lZeile = 2
     With oExcelWorkbook.sheets("signature")
         Do While .Cells(lZeile, 1) <> ""
             ComboBox3.AddItem CStr(.Cells(lZeile, 2).Value)
             lZeile = lZeile + 1
         Loop
     End With
       
     oExcelWorkbook.Close False
     oExcelApp.Quit
      
   Set oExcelWorkbook = Nothing
   Set oExcelApp = Nothing
End Sub

Freue mich über jeden Tipp oder jede Lösung und bedanke mich schon einmal vielmals im Voraus

Ihre Antwort

Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema:		Name:		Email:

Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema	Datum	Von Nutzer	Rating	Antwort
Word Userform Excel-Abfragen zusammenfassen	23.10.2015 20:20:19	xtoph