Moin,

Vorerst: Ich bin VBA-Anfänger.

Ich sitzte derzeit an ein Projekt um meine Protokolle, die ich für eine Hausarbeit erstelle, organisiert zu dokumentieren und abzuspeichern. 

Mein Gedanke: Ich öffne eine Exceltebelle, es wird die nächstfreie Zeile ausgewählt, darin schreibe ich die wichtigsteneckpunkte zum Protokoll, (Ersteller, Thema, Lehrer, Fach) und über ein Button wird mir aus einer Protokollvorlage ein leeres Dokument erstellt welches die wichtigen Eckpunkte besitzt und es wird ein Speicherort dafür vorgesehen (Der Speicherort wird über ein Auswahlverfahren ermittelt). 

Wenn ich dieses auf meine Festplatte speicher ist das alles kein Problem.

Nun möchte ich jedoch alles in die Dropbox speichern. Diese Dropbox ist auf meinem Heimrechner, auf meinem Schulrechner und auf einem Rechner eines Kollegen, der auch auf dieses Exceldokument und auf die Protokolle zu greifen muss.

Der Code:

Sub Schaltfläche1_Klicken()

Dim Wordapp As Object, Worddoc As Object
Dim letzteZelle As String, Pfad As String, Ersteller As String, Thema As String, Fach As String, Lehrer As String, Vorlage As String, Protokollname As String
Dim Schreibbereich As Range
Dim zellenindex As Integer

With ThisWorkbook.ActiveSheet
  
  'Word starten
  Set Wordapp = CreateObject("Word.application")
  'Pfadangabe Vorlage
  Vorlage = .Cells(8, 1)
  'Füge ein neues Dokument in die Protokollvorlage
  Wordapp.Documents.Add Vorlage & "Protokollvorlage.dotx"
  
  'Pfadangeabe Projektordner
  Pfad = .Cells(6, 1)
    
  
  'letzte Zeile ermitteln
  letzteZelle = .Cells(Rows.Count, 2).End(xlUp).Row - 10
  
  'Thema ermitteln
  Thema = .Cells(Rows.Count, 2).End(xlUp).Value
  
  'Ersteller ermitteln
  Ersteller = .Cells(Rows.Count, 3).End(xlUp).Value
  
  'Fach ermitteln
  Fach = .Cells(Rows.Count, 4).End(xlUp).Value
  
  'Lehrer ermitteln
  Lehrer = .Cells(Rows.Count, 5).End(xlUp).Value
  'Auswahl des neuen Speicherpfad
  If Lehrer = "Ziegert" Then
  Pfad = Pfad & "Ziegert\Protokoll\"
  ElseIf Lehrer = "Tschersich" Then
  Pfad = Pfad & "Tschersich\Protokoll\"
  ElseIf Lehrer = "Bues" Then
  Pfad = Pfad & "Bues\Protokoll\"
  ElseIf Lehrer = "Mundt" Then
  Pfad = Pfad & "Mundt\Protokoll\"
  End If
  
  'übergabe der Eckdaten
  Set Worddoc = Wordapp.ActiveDocument
      With Worddoc
        .BuiltinDocumentProperties("Title").Value = Thema
        .BuiltinDocumentProperties("Manager").Value = Lehrer
        .BuiltinDocumentProperties("Category").Value = Fach
        .BuiltinDocumentProperties("Author").Value = Ersteller
        .BuiltinDocumentProperties("Subject").Value = Date
      End With
      
  
 'Erstellung des Protokollnamen
  Protokollname = letzteZelle & "_" & Date & "_" & Thema & ".docx"
 'Auswahl der Zelle in dem der Protokollname steht
 .Cells(letzteZelle + 10, 1).Select
 'Erstellung eines Hyperlink für das erstellte Protokoll
 .Hyperlinks.Add Anchor:=Selection, Address:=Pfad & Protokollname
 .Cells(letzteZelle + 10, 1).Value = Protokollname
                   
 'Word Dokument speichern
  Worddoc.SaveAs (Pfad & Protokollname)
 
 'Worddokument öffnen
  Wordapp.Documents.Open Pfad & Protokollname
 'Worddokument in den Vordergrund holen
  Wordapp.Activate
 
  
    'Zeile die Makiert war wieder weiß hinterlegen
    zellenindex = Cells(Rows.Count, 1).End(xlUp).Row
    Set Schreibbereich = Range("A" & zellenindex & ":E" & zellenindex)
    Schreibbereich.Select
      With Selection.Interior
        .ThemeColor = xlThemeColorDark1
      End With
     
     
End With
'Tabelle Aktualisieren
ThisWorkbook.Worksheets("Tabelle2").Activate
ThisWorkbook.Worksheets("Tabelle1").Activate



End Sub


____________________________________________________________

'Bei aktualisierung der Tabelle1 wird die nächsteZeile ausgewählt und Gelbmakiert
'Sodas der benutzer weiß in welche zeile er schreiben soll

Private Sub Worksheet_Activate()

Dim Schreibbereich As Range
Dim zellenindex As Integer
 
zellenindex = Cells(Rows.Count, 1).End(xlUp).Row + 1
Set Schreibbereich = Range("A" & zellenindex & ":E" & zellenindex)
Schreibbereich.Select
 With Selection.Interior
        .Color = 65535
 End With



End Sub