Änderungen protokollieren

    • VBA: Excel

      Änderungen protokollieren

      Hallo liebe Community,

      Wenn mehrere Anwender (Team) an Excel-Tabellen arbeiten oder Arbeitsmappen der Reihe nach an verschiedene Empfänger (Teammitglieder) verteilt werden, ist es sinnvoll, Änderungen genau zu erfassen und zu protokollieren. Wer hat zu welchem Zeitpunkt welche Zelle verändert?
      Excel bietet Ihnen für diese Aufgabe eine passende Funktion an. Diese Funktion zeichnet Änderungen an Zellen auf.

      Ich möchte heute Ihnen ein VBA-Projekt vorstellen, das ähnliche Funktion wie Excel hat aber die Änderungen durch den Anwender erfasst werden.

      Gehen Sie dazu wie folgt vor:

      1) Starten Sie Excel
      2) Wenn Sie kein Arbeitsblatt sehen. Fügen Sie eine neue Arbeitsmappe ein (Datei--> Neu--> Leere Arbeitsmappe)
      3) Wechseln Sie mit Tastenkombination Alt+F11 zu VBA -Editor
      4) Fügen Sie ein Modul ein (Einfügen--> Modul) Ändern Sie (Name)-Eigenschaft von Modul1 nicht.
      5) Fügen Sie eine Userform ein (Einfügen--> UserForm) Ändern Sie (Name)-Eigenschaft von UserForm1 von UserForm1 auf "frmAenderungen_verwalten"
      6) Wechseln Sie mit Tastenkombination Alt+F11 zurück zu Excel
      7) Ändern Sie den Namen von Arbeitsblatt Tabelle1 auf "Aenderungen_erf" und blenden Sie das Arbeitsblatt "Aenderungen_erf" aus.(Rechtsklick auf das Arbeitsblatt "Aenderungen_erf" --> Ausblenden)
      8) Aktivieren Sie das Arbeitsblatt "Tabelle2" und fügen Sie Eine Schaltfläche ein [Entwicklertools--> Einfügen--> Schaltfläche (Formularsteuerelement)]
      Benennen Sie Schaltfläche 1 um. Geben Sie Ihre Schaltfläche den Namen "START" (Später werden wir der Schaltfläche das Makro "testmich" zuweisen)

      9) Speichern Sie die Arbeitsmappe (Excel-Arbeitsmappe mit Makros (*.xlsm). Geben Sie einen neuen Namen für die Datei ein

      10) Kopieren Sie den folgenden Code und fügen Sie ihn in Modul1 ein.
      Spoiler anzeigen

      Visual Basic-Quellcode

      1. 'Code Modul1
      2. Option Explicit
      3. Option Compare Text
      4. Option Base 1
      6. 'Blattname in Dokument
      7. Public Const strTabname As String = "Aenderungen_erf"
      9. 'Internationale Einstellungen
      11. Public LgDataOrder As Long
      12. Public strDateSeparator As String
      13. Public strTimeSeperator As String
      14. Public strDecimalSeparator As String
      16. Public strDataOrder As String
      18. Public Const strDayCode As String = "DD"
      19. Public Const strMonthCode As String = "MM"
      20. Public strYearCode As String
      22. '*********************************************************************
      23. Public Declare Function GetUserName Lib "advapi32.dll" _
      24. Alias "GetUserNameA" _
      25. (ByVal lpBuffer As String, nSize As Long) As Long
      26. '*********************************************************************
      28. Public Function AnwenderName_Aktuell() As String
      29. Dim s As String
      30. Dim cnt As Long
      31. Dim ret As Long
      32. Dim pos As Integer
      34. cnt = 199
      35. s = String$(200, 0)
      36. ret = GetUserName(s, cnt)
      37. If ret <> 0 Then
      38. AnwenderName_Aktuell = Trim$(Left$(s, cnt))
      39. pos = InStr(AnwenderName_Aktuell, Chr$(0))
      40. If pos > 0 Then
      41. AnwenderName_Aktuell = Left$(AnwenderName_Aktuell, pos - 1)
      42. Else
      43. AnwenderName_Aktuell = AnwenderName_Aktuell
      44. End If
      45. Else
      46. AnwenderName_Aktuell = "User"
      47. End If
      48. On Error Resume Next
      49. Application.UserName = AnwenderName_Aktuell
      50. On Error GoTo 0
      51. End Function
      53. Sub testmich()
      55. 'uebliche prozedur
      57. 'strDayCode = Application.International(xlDayCode)
      58. 'strMonthCode = Application.International(xlMonthCode)
      60. 'strYearCode = Application.International(xlYearCode)
      61. 'strHourCode = Application.International(xlHourCode)
      62. 'strSecondCode = Application.International(xlSecondCode)
      64. If Application.International(xl4DigitYears) Then
      65. strYearCode = "YYYY" 'strYearCode & strYearCode & strYearCode & strYearCode
      66. Else
      67. strYearCode = "YY" 'strYearCode & strYearCode
      68. End If
      70. strDateSeparator = Application.International(xlDateSeparator)
      72. 'Select Case strDateSeparator
      73. ' Case Is = "."
      74. '
      75. ' Case Is = "/"
      76. '
      77. ' Case Else
      78. '
      79. ' Exit Sub
      80. 'End Select
      82. strTimeSeperator = Application.International(xlTimeSeparator)
      83. strDecimalSeparator = Application.International(xlDecimalSeparator)
      85. LgDataOrder = Application.International(xlDateOrder)
      86. Select Case LgDataOrder
      88. Case 0 'M-T-J
      89. strDataOrder = strMonthCode & strDateSeparator _
      90. & strDayCode & strDateSeparator & strYearCode
      91. Case 1 'T-M-J Deutsch
      92. strDataOrder = strDayCode & strDateSeparator _
      93. & strMonthCode & strDateSeparator & strYearCode
      95. Case 2 'J-M-T
      96. strDataOrder = strYearCode & strDateSeparator _
      97. & strMonthCode & strDateSeparator & strDayCode
      99. End Select
      101. 'ist das Blatt Aenderungen_erf vorhanden
      102. If Tabelle_vorhanden(strTabname) Then
      103. 'Dialog anzeigen
      104. frmAenderungen_verwalten.Show 0 'Modal = UserForm ist ungebunden
      105. End If
      107. End Sub
      109. Function Tabelle_vorhanden(strT_Name As String) As Boolean
      110. Dim i&
      112. For i = Application.Worksheets.Count To 1 Step -1
      113. If Application.Worksheets(i).Name = strT_Name Then Tabelle_vorhanden = True: Exit Function
      114. Next
      116. End Function
      118. Function Aenderungen_Erfa_Bear_Index(intErkennung As Integer)
      119. Dim i As Long, lgRow As Long, ws As Worksheet, wsActiv As Worksheet
      121. Dim glArray()
      123. 'intErkennung:
      124. '0=Index
      125. '1=Aenderungstext
      126. '2=Eintrag am
      127. '3 = Eintrag vom
      128. '4 = Geändert am
      129. '5 = Geändert vom
      131. On Error GoTo ErrH
      132. Application.ScreenUpdating = False
      133. Erase glArray()
      134. 'Verweis auf aktives Blatt
      135. Set wsActiv = Application.ActiveSheet
      136. 'Verweis auf Blatt aenderungen_erf
      137. Set ws = Application.ActiveWorkbook.Worksheets(strTabname)
      138. 'um einem ausgeblendeten Blatt zuzugreifen vorher Blatt aktivieren
      139. ws.Activate
      141. With ws
      142. lgRow = .Cells(Rows.Count, 1).End(xlUp).Row
      143. If lgRow > 1 Then
      145. Select Case intErkennung
      146. Case 0
      147. For i = 2 To lgRow 'To Anzahl der Zellen in Spalte A die mit Daten belegt sind
      148. 'z.B intRow = Cells(Rows.Count, 1).End(xlUp).Row
      149. ReDim Preserve glArray(i)
      150. glArray(i) = .Range(Cells(i, 1), Cells(i, 1)).Value
      151. Next
      152. Aenderungen_Erfa_Bear_Index = glArray
      154. Case 1
      155. For i = 2 To lgRow 'To Anzahl der Zellen in Spalte A die mit Daten belegt sind
      156. 'z.B intRow = Cells(Rows.Count, 1).End(xlUp).Row
      157. ReDim Preserve glArray(i)
      158. glArray(i) = .Range(Cells(i, 2), Cells(i, 2)).Value
      159. Next
      160. Aenderungen_Erfa_Bear_Index = glArray
      162. Case 2
      163. For i = 2 To lgRow 'To Anzahl der Zellen in Spalte A die mit Daten belegt sind
      164. 'z.B intRow = Cells(Rows.Count, 1).End(xlUp).Row
      165. ReDim Preserve glArray(i)
      166. glArray(i) = .Range(Cells(i, 3), Cells(i, 3)).Value
      167. Next
      168. Aenderungen_Erfa_Bear_Index = glArray
      169. Case 3
      170. For i = 2 To lgRow 'To Anzahl der Zellen in Spalte A die mit Daten belegt sind
      171. 'z.B intRow = Cells(Rows.Count, 1).End(xlUp).Row
      172. ReDim Preserve glArray(i)
      173. glArray(i) = .Range(Cells(i, 4), Cells(i, 4)).Value
      174. Next
      175. Aenderungen_Erfa_Bear_Index = glArray
      177. Case 4
      178. For i = 2 To lgRow 'To Anzahl der Zellen in Spalte A die mit Daten belegt sind
      179. 'z.B intRow = Cells(Rows.Count, 1).End(xlUp).Row
      180. ReDim Preserve glArray(i)
      181. glArray(i) = .Range(Cells(i, 5), Cells(i, 5)).Value
      182. Next
      183. Aenderungen_Erfa_Bear_Index = glArray
      185. Case 5
      187. For i = 2 To lgRow 'To Anzahl der Zellen in Spalte A die mit Daten belegt sind
      188. 'z.B intRow = Cells(Rows.Count, 1).End(xlUp).Row
      189. ReDim Preserve glArray(i)
      190. glArray(i) = .Range(Cells(i, 6), Cells(i, 6)).Value
      191. Next
      192. Aenderungen_Erfa_Bear_Index = glArray
      195. End Select
      197. Else
      198. Aenderungen_Erfa_Bear_Index = Array("0_0")
      199. End If
      200. End With
      201. Set ws = Nothing
      202. wsActiv.Activate
      203. Set wsActiv = Nothing
      204. Application.ScreenUpdating = True
      205. ErrH:
      206. If Err <> 0 Then
      207. Application.ScreenUpdating = True
      208. MsgBox Err.Description, , "FEHLER"
      209. Aenderungen_Erfa_Bear_Index = Array("F_F")
      210. Set ws = Nothing
      211. wsActiv.Activate
      212. Set wsActiv = Nothing
      213. End If
      214. End Function
      216. Function AenderungsTextLoeschen_Text_Alles(intErk As Integer, intZeile As Integer) As Boolean
      218. Dim i As Integer, lgRow As Long, lgZeile As Long
      219. Dim ws As Worksheet, wsActiv As Worksheet
      221. On Error GoTo ErrH
      222. 'intErk = 0 Text Loeschen
      223. 'intErk = 1 Alles Loeschen
      225. Application.ScreenUpdating = False
      226. 'Verweis auf aktives Blatt
      227. Set wsActiv = Application.ActiveSheet
      228. 'Verweis auf Blatt aenderungen_erf
      229. Set ws = Application.ActiveWorkbook.Worksheets(strTabname)
      230. 'um einem ausgeblendeten Blatt zuzugreifen vorher Blatt aktivieren
      231. ws.Activate
      233. With ws
      234. lgRow = .Cells(Rows.Count, 1).End(xlUp).Row
      235. 'nur 300 Zeilen erlauben
      236. If lgRow > 300 Then
      237. Set ws = Nothing
      238. wsActiv.Activate
      239. Set wsActiv = Nothing
      240. Application.ScreenUpdating = True
      241. Exit Function
      243. End If
      244. If lgRow > 1 Then
      246. Select Case intErk
      248. Case 0
      249. 'wenn intZeile +1 = lgRow dann es ist nur
      250. 'eine Zeile vorhanden. Erste Zeile
      251. If lgRow = 2 And lgRow = intZeile + 1 Then
      252. .Range(Cells(lgRow, 1), Cells(lgRow, 6)).ClearContents
      253. AenderungsTextLoeschen_Text_Alles = True
      255. Set ws = Nothing
      256. wsActiv.Activate
      257. Set wsActiv = Nothing
      258. Application.ScreenUpdating = True
      259. Exit Function
      260. End If
      262. 'wenn lgRow = intZeile + 1 dann letzte Zeile
      264. If lgRow = intZeile + 1 Then
      265. .Range(Cells(lgRow, 1), Cells(lgRow, 6)).ClearContents
      266. AenderungsTextLoeschen_Text_Alles = True
      268. Set ws = Nothing
      269. wsActiv.Activate
      270. Set wsActiv = Nothing
      271. Application.ScreenUpdating = True
      272. Exit Function
      273. End If
      275. 'von intZeile + 1 (+1) aus
      276. 'bis Ende (letzte Zeile) kopieren
      278. .Range(Cells(intZeile + 1 + 1, 1), Cells(lgRow, 6)).Copy
      280. 'intZeile (+1) einfügen
      281. .Range(Cells(intZeile + 1, 1), Cells(intZeile + 1, 1)).PasteSpecial (xlPasteValues)
      282. .Range(Cells(lgRow, 1), Cells(lgRow, 6)).ClearContents
      283. Application.CutCopyMode = False
      284. 'letzte Zeilennummer finden
      285. lgZeile = .Cells(Rows.Count, 1).End(xlUp).Row
      287. For i = 1 To lgZeile - 1
      288. .Range(Cells(i + 1, 1), Cells(i + 1, 1)).Value = i
      289. Next
      290. .Range(Cells(2, 1), Cells(2, 1)).Select
      291. AenderungsTextLoeschen_Text_Alles = True
      292. Case 1
      293. .Range(Cells(2, 1), Cells(lgRow + 1, 6)).ClearContents
      294. AenderungsTextLoeschen_Text_Alles = True
      295. Case Else
      296. AenderungsTextLoeschen_Text_Alles = False
      297. End Select
      299. Else
      300. AenderungsTextLoeschen_Text_Alles = True
      301. End If
      303. End With
      305. Set ws = Nothing
      306. wsActiv.Activate
      307. Set wsActiv = Nothing
      308. Application.ScreenUpdating = True
      309. ErrH:
      310. If Err <> 0 Then
      311. MsgBox Err.Description, , "FEHLER"
      312. AenderungsTextLoeschen_Text_Alles = False
      313. Set ws = Nothing
      314. wsActiv.Activate
      315. Set wsActiv = Nothing
      316. Application.ScreenUpdating = True
      317. End If
      319. End Function
      321. 'String Buchstabe fuer Buchstabe nach Zeichen durchsuchen
      323. Function TextnachZeichen_Durchforsten(ByVal strText As String, _
      324. ByVal strZeichen As String) As Long
      326. Dim strZ As String, i&, s&
      327. s = 0
      328. For i = 1 To Len(strText)
      329. strZ = Mid(strText, i, 1)
      330. If InStr(strZeichen, strZ) <> 0 Then
      331. s = s + 1
      332. End If
      333. Next i
      334. TextnachZeichen_Durchforsten = s
      335. End Function


      '#############################################################################################

      11) Nun können Sie der Schaltfläche das Makro "testmich" zuweisen
      Spoiler anzeigen

      ' UserForm

      Ok jetzt nehmen wir uns die UserForm "frmAenderungen_verwalten" vor.

      Wichtigste Eigenschaften von "frmAenderungen_verwalten":
      Caption: A E N D E R U N G E N E R F A S S E N / B E A R B E I T E N
      Height: 424,5
      Width: 465,75
      Left: 0
      Top: -2,25

      12) Fügen Sie der UserForm zwei Beschriftungsfeld zu. Ändern Sie die (Name)-Eigenschaft Label1 --> lbIndex, Label2--> lbAenderungen
      Spoiler anzeigen

      a) Eigenschaften von lbIndex
      Caption: INDEX
      Height: 10
      Width: 36
      Left: 12
      Top: 3

      b) Eigenschaften von lbAenderungen
      Caption: A E N D E R U N G S T E X T
      Height: 12
      Width: 216
      Left: 120
      Top: 3
      TextAlign 2 - fmTextAlignCenter

      13) Fügen Sie der UserForm eine Listbox zu. Ändern Sie die (Name)-Eigenschaft ListBox1 --> lsbAenderungen
      Spoiler anzeigen

      Eigenschaften von lsbAenderungen
      Height: 156
      Width: 449
      Left: 6
      Top: 17,25
      TextAlign 2 - fmTextAlignLeft

      14) Fügen Sie der UserForm zwei Rahmen zu. Ändern Sie die (Name)-Eigenschaften nicht.
      Spoiler anzeigen

      a) Eigenschaften von Frame1
      Caption: AENDERUNGEN
      Height: 145
      Width: 450
      Left: 6
      Top: 179
      Font: Thoma Fett 9

      b) Eigenschaften von Frame2
      Caption: DATUM AENDERN
      Height: 80
      Width: 92
      Left: 364
      Top: 318
      Font: Thoma Fett 8

      15) Aktivieren Sie Frame1. Fügen Sie vier Befehlsschaltfläche, fünf Beschriftungsfeld, zwei Textbox und ein DTPicker zu.
      Spoiler anzeigen

      a) Eigenschaften von Befehlsschaltflächen

      a.1
      (Name): cmdNeu
      Caption: NEU
      Height: 20
      Width: 65
      Left: 4
      Top: 9

      a.2
      (Name): cmdInsert
      Caption: EINFUEGEN
      Height: 20
      Width: 65
      Left: 4
      Top: 40

      a.3
      (Name): cmdEdit
      Caption: BEARBEITEN
      Height: 20
      Width: 65
      Left: 4
      Top: 78

      a.4
      (Name): cmdEinfuegen_bea
      Caption: EINFUEGEN
      Height: 20
      Width: 65
      Left: 4
      Top: 109

      b) Eigenschaften von Beschriftungsfeld

      b.1
      (Name): lbDatumNeu
      Caption: D A T U M
      Height: 16
      Width: 75
      Left: 278
      Top: 28

      b.2
      (Name): Label1
      Caption: Eingetragen am
      Height: 16
      Width: 75
      Left: 278
      Top: 79

      b.3
      (Name): Label3
      Caption: Geaendert am
      Height: 16
      Width: 75
      Left: 278
      Top: 112

      b.4
      (Name): lbDatumVorh
      Caption: Datum
      Height: 16
      Width: 80
      Left: 361
      Top: 79

      b.5
      (Name): Label4
      Caption: Datum
      Height: 16
      Width: 80
      Left: 361
      Top: 112

      c) Eigenschaften von DTPicker
      (Name): DTPicker1
      Height: 15,75
      Width: 78
      Left: 361
      Top: 28
      Value: 09.09.2013

      d) Eigenschaften von Texbox

      d.1
      (Name): txtNeu
      Height: 50
      Width: 200
      Left: 73
      Top: 10
      MultiLine: True

      d.2
      (Name): txtEdit
      Height: 50
      Width: 200
      Left: 73
      Top: 79
      MultiLine: True

      16) Aktivieren Sie Frame2. Fügen Sie zwei Optionsfeld und ein DTPicker zu.
      Spoiler anzeigen

      a) Eigenschaften von Optionsfeld

      a.1
      (Name): OptionButton1
      Caption: Eingetragen
      Height: 15
      Width: 70
      Left: 6
      Top: 8
      TextAlign 2 - fmTextAlignCenter

      a.2
      (Name): OptionButton2
      Caption: Geaendert
      Height: 15
      Width: 70
      Left: 6
      Top: 29
      TextAlign 2 - fmTextAlignCenter

      b) Eigenschaften von DTPicker
      (Name): DTPicker2
      Height: 18
      Width: 77,25
      Left: 7
      Top: 48
      Value: 09.09.2013

      17) Aktivieren Sie die UserForm "frmAenderungen_verwalten" und fügen Sie vier Befehlsschaltfläche zu.
      Spoiler anzeigen

      a) Eigenschaften von Befehlsschaltflächen

      a.1
      (Name): cmdLoeschen
      Caption: TEXT LOESCHEN
      Height: 30
      Width: 75
      Left: 6
      Top: 326

      a.2
      (Name): cmdAlles
      Caption: ALLES LOESCHEN
      Height: 30
      Width: 75
      Left: 6
      Top: 364

      a.3
      (Name): cmdUndo
      Caption: ALLES VERWERFEN
      Height: 30
      Width: 75
      Left: 285
      Top: 326
      WordWrap: True

      a.4
      (Name): cmdExit
      Caption: EXIT
      Height: 30
      Width: 75
      Left: 285
      Top: 364


      '################################################################################
      'UserForm-Gestaltung Ende
      '################################################################################

      18) Klicken Sie mit der rechten Maustaste auf eine freie Fläche der UserForm "frmAenderungen_verwalten" und wählen aus dem Kontexmenü den Befehl"Code anzeigen". Im Codebereich fügen Sie folgende ereignismakros zu

      Spoiler anzeigen

      Quellcode

      1. Option Explicit
      2. 'Option Compare Text
      3. Option Base 1
      5. Private blAll As Boolean
      7. Dim txtInBearbeitung As String
      8. 'Variablen die in Bearbeitung benötigt werden
      9. Dim varIndex, varAender, varDat, varUser, varDat_geaen, varUser_geaen
      10. 'alle Aenderungen verwerfen
      11. Dim varStand_1_Index, varStand_1_Aender, varStand_1_Dat, varStand_1_User, varStand_1_Datgeaen, varStand_1_Usergeaen
      13. '###############################################
      15. '#####################################################
      17. 'alle Aenderungstexte werden gelöscht
      19. Private Sub cmdAlles_Click()
      20. If MsgBox("Alle Aenderungstexte werden geloescht. Fortfahren?", vbOKCancel, "NEU PROJEKT") = vbOK Then
      21. 'alles löschen
      22. If AenderungsTextLoeschen_Text_Alles(1, 0) Then
      23. Call Form_Clear
      24. Call VariablenInitialisieren
      25. Me.cmdUndo.Enabled = True
      26. blAll = True
      27. End If
      29. End If
      30. End Sub
      32. Private Sub cmdEdit_Click()
      34. Me.txtNeu.Value = ""
      35. Me.txtNeu.Enabled = False
      37. Me.txtEdit.Enabled = True
      38. txtEdit.Value = varAender(Me.lsbAenderungen.ListIndex + 2)
      39. Me.cmdLoeschen.Enabled = False
      40. Me.cmdLoeschen.Caption = "TEXT LOESCHEN"
      41. Me.lbDatumVorh.Caption = varDat(Me.lsbAenderungen.ListIndex + 2)
      42. Me.Label4.Caption = varDat_geaen(Me.lsbAenderungen.ListIndex + 2)
      43. Me.OptionButton1.Value = False
      44. Me.OptionButton2.Value = False
      46. Me.OptionButton1.Enabled = True
      47. Me.OptionButton2.Enabled = True
      49. txtInBearbeitung = txtEdit.Value
      50. On Error GoTo ErrH
      51. 'Me.DTPicker2.Value = varDat(Me.lsbAenderungen.ListIndex + 2)
      52. Me.DTPicker2.Value = Date
      53. If Me.DTPicker2.Value = "00:00:00" Then
      54. Me.DTPicker2.Value = Date
      55. End If
      56. ErrH:
      57. If Err <> 0 Then
      58. Me.DTPicker2.Value = Date
      59. End If
      60. On Error GoTo 0
      62. End Sub
      64. 'vorhandene Texte bearbeitet. wird an der gleichen stelle neu eingefügt
      65. Private Sub cmdEinfuegen_bea_Click()
      67. Dim strText As String, strZeichen$
      69. strZeichen = " " & vbCr & vbBack & vbCrLf & vbLf & vbTab & vbVerticalTab
      70. strText = Me.txtEdit.Value
      72. strText = Trim$(strText)
      74. If Trim$(txtInBearbeitung) = strText And Me.OptionButton1.Value = False _
      75. And Me.OptionButton2.Value = False Then
      76. txtInBearbeitung = ""
      77. Me.txtEdit.Value = ""
      78. Me.txtEdit.SetFocus
      79. Me.OptionButton1.Value = False
      80. Me.OptionButton2.Value = False
      82. Me.OptionButton1.Enabled = False
      83. Me.OptionButton2.Enabled = False
      84. 'MsgBox "Text ist nicht geaendert"
      85. Exit Sub
      86. Else 'entweder Text geaendert oder eine von OptionButton gewählt
      87. If TextnachZeichen_Durchforsten(strText, strZeichen) <> Len(strText) Then
      88. Select Case True
      89. Case Me.OptionButton1.Value
      90. Call Text_Geaendert_Eintragen(0, Me.lsbAenderungen.ListIndex, 3)
      91. Case Me.OptionButton2.Value
      92. Call Text_Geaendert_Eintragen(0, Me.lsbAenderungen.ListIndex, 5)
      93. Case Else
      94. Call Text_Geaendert_Eintragen(0, Me.lsbAenderungen.ListIndex)
      95. End Select
      97. Call Form_Clear
      98. Call VariablenInitialisieren
      99. Me.cmdUndo.Enabled = True
      100. blAll = True
      101. Else
      102. MsgBox "Leerzeichen werden nicht eingefügt.", vbOKOnly + vbInformation
      103. Me.txtEdit.Value = ""
      104. Me.txtEdit.SetFocus
      105. End If
      107. End If
      109. End Sub
      111. 'Neue Text wird der liste angehängt
      112. Private Sub cmdInsert_Click()
      113. Dim strText As String, strZeichen$
      115. strZeichen = " " & vbCr & vbBack & vbCrLf & vbLf & vbTab & vbVerticalTab
      117. strText = Me.txtNeu.Value
      119. strText = Trim$(strText)
      121. If TextnachZeichen_Durchforsten(strText, strZeichen) <> Len(strText) Then
      123. Call Text_Geaendert_Eintragen(1, 5001)
      125. Call Form_Clear
      126. Call VariablenInitialisieren
      127. Me.cmdUndo.Enabled = True
      128. blAll = True
      129. Else
      130. MsgBox "Leerzeichen werden nicht eingefügt.", vbOKOnly + vbInformation
      131. Me.txtNeu.Value = ""
      132. Me.txtNeu.SetFocus
      133. End If
      134. End Sub
      136. 'Neue Text wird von der Liste wegradiert
      137. Private Sub cmdLoeschen_Click()
      138. If Trim$(Me.txtEdit.Value) <> "" Then Exit Sub
      139. If MsgBox("Aenderungstext : " & vbCr & _
      140. varAender(Me.lsbAenderungen.ListIndex + 2) & vbCr & "Loeschen?", vbOKCancel + vbInformation, "NN NNN") = vbOK Then
      141. If AenderungsTextLoeschen_Text_Alles(0, Me.lsbAenderungen.ListIndex + 1) Then
      143. Call Form_Clear
      144. Call VariablenInitialisieren
      145. Me.cmdUndo.Enabled = True
      146. blAll = True
      147. End If
      149. End If
      150. End Sub
      152. ' Click-Ereignis cmdNeu
      154. Private Sub cmdNeu_Click()
      155. Me.txtNeu.Enabled = True
      156. Me.cmdEinfuegen_bea.Enabled = False
      157. Me.DTPicker1.Value = Date
      158. Me.txtNeu.SetFocus
      159. Me.txtEdit.Value = ""
      160. Me.txtEdit.Enabled = False
      162. Me.OptionButton1.Value = False
      163. Me.OptionButton2.Value = False
      165. Me.OptionButton1.Enabled = False
      166. Me.OptionButton2.Enabled = False
      168. End Sub
      170. ' Click-Ereignis cmdUndo
      172. Private Sub cmdUndo_Click()
      173. If MsgBox("Alle Vorgaenge werden zurückgesetzt. Fortfahren?", vbOKCancel + vbQuestion, "NEU PROJEKT") = vbOK Then
      174. Call AenderungsText_ZurueckSchreiben
      175. Call Form_Clear
      176. Call VariablenInitialisieren
      177. blAll = True
      178. End If
      179. End Sub
      181. ' Click-Ereignis lsbAenderungen
      182. Private Sub lsbAenderungen_Click()
      183. Me.cmdLoeschen.Enabled = (Me.lsbAenderungen.ListCount > -1)
      185. If Me.cmdLoeschen.Enabled = True Then
      186. Me.cmdLoeschen.Caption = "INDEX [ " & Me.lsbAenderungen.ListIndex + 1 & _
      187. " ] LOESCHEN"
      188. End If
      189. Me.lbDatumVorh.Caption = varDat(Me.lsbAenderungen.ListIndex + 2)
      190. Me.Label4.Caption = varDat_geaen(Me.lsbAenderungen.ListIndex + 2)
      191. Me.cmdEdit.Enabled = (Me.lsbAenderungen.ListCount > -1)
      192. Me.txtEdit.Value = ""
      193. Me.txtEdit.Enabled = False
      194. End Sub
      196. ' DblClick-Ereignis lsbAenderungen
      198. Private Sub lsbAenderungen_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
      199. If Me.lsbAenderungen.ListIndex < 0 Then Cancel = True: Exit Sub
      200. MsgBox "INDEX : " & Me.lsbAenderungen.ListIndex + 1 & vbCr & vbCr _
      201. & "TEXT : " & varAender(Me.lsbAenderungen.ListIndex + 2) & vbCr & vbCr _
      202. & "EINTRAG AM : " & varDat(Me.lsbAenderungen.ListIndex + 2) & vbCr _
      203. & "EINTRAG VOM : " & varUser(Me.lsbAenderungen.ListIndex + 2) & vbCr _
      204. & "GEAENDERT AM : " & varDat_geaen(Me.lsbAenderungen.ListIndex + 2) & vbCr _
      205. & "GEAENDERT VOM : " & varUser_geaen(Me.lsbAenderungen.ListIndex + 2) & vbCr
      208. End Sub
      210. 'DblClick-Ereignis OptionButton1
      211. Private Sub OptionButton1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
      212. Cancel = True
      213. Me.OptionButton1.Value = False
      214. End Sub
      216. 'DblClick-Ereignis OptionButton2
      217. Private Sub OptionButton2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
      218. Cancel = True
      219. Me.OptionButton2.Value = False
      220. End Sub
      222. 'Change-Ereignis txtEdit
      223. Private Sub txtEdit_Change()
      224. Me.cmdEinfuegen_bea.Enabled = (Me.txtEdit.Value <> "")
      225. Me.cmdLoeschen.Enabled = (Me.txtEdit.Value = "")
      227. If Me.cmdLoeschen.Enabled = True Then
      228. Me.cmdLoeschen.Caption = "INDEX [ " & Me.lsbAenderungen.ListIndex + 1 & _
      229. " ] LOESCHEN"
      230. End If
      231. Me.DTPicker2.Enabled = (Me.txtEdit.Value <> "")
      233. Me.OptionButton1.Value = False
      234. Me.OptionButton2.Value = False
      236. Me.OptionButton1.Enabled = (Me.txtEdit.Value <> "")
      237. Me.OptionButton2.Enabled = (Me.txtEdit.Value <> "")
      239. If Len(Me.txtEdit.Value) <= 0 Then Exit Sub
      240. If Len(Me.txtEdit.Value) > 120 Then
      241. Me.txtEdit.Value = Left$(Me.txtEdit.Value, 120)
      242. End If
      244. End Sub
      246. 'KeyDown-Ereignis txtEdit
      247. Private Sub txtEdit_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      249. If KeyCode = 13 Then 'Return-Taster Eingabetaster
      250. KeyCode = 0
      251. End If
      252. End Sub
      254. 'Change-Ereignis txtNeu
      256. Private Sub txtNeu_Change()
      257. Me.cmdInsert.Enabled = (Me.txtNeu.Value <> "")
      258. Me.cmdNeu.Enabled = (Me.txtNeu.Value = "")
      259. Me.DTPicker1.Enabled = (Me.txtNeu.Value <> "")
      260. Me.txtEdit.Value = ""
      261. Me.txtEdit.Enabled = False
      262. If Len(Me.txtNeu.Value) <= 0 Then Exit Sub
      263. If Len(Me.txtNeu.Value) > 120 Then
      264. Me.txtNeu.Value = Left$(Me.txtNeu.Value, 120)
      265. End If
      266. End Sub
      268. 'KeyDown-Ereignis txtNeu
      270. Private Sub txtNeu_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      271. If KeyCode = 13 Then 'Return-Taste Eingabetaster
      272. KeyCode = 0
      273. End If
      275. End Sub
      277. Private Sub UserForm_Initialize()
      279. 'intErkennung:
      280. '0=Index
      281. '1=Aenderungstext
      282. '2=Datum
      284. Call VariablenInitialisieren
      286. varStand_1_Index = varIndex
      287. If varStand_1_Index(1) = "F_F" Then Exit Sub
      288. varStand_1_Aender = varAender
      289. varStand_1_Dat = varDat
      290. varStand_1_User = varUser
      291. varStand_1_Datgeaen = varDat_geaen
      292. varStand_1_Usergeaen = varUser_geaen
      294. 'Application.ScreenUpdating = True
      295. End Sub
      297. Private Sub cmdExit_Click()
      298. Unload Me
      299. End
      300. End Sub
      302. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      303. 'If MsgBox("wirklich verlassen?", vbOKCancel + vbQuestion, "NEU PROJEKT") = vbOK Then
      304. Cancel = False
      305. If blAll = True Then
      306. Me.Hide
      307. Call AenderungsBlattFormatieren
      308. End If
      309. blAll = False
      310. If CloseMode = 0 Then Call cmdExit_Click
      311. Exit Sub
      312. ' Else
      313. Cancel = True: Exit Sub
      314. ' End If
      315. 'Dialogschliessen über das Kreuz verhindern
      316. 'If CloseMode <> 1 Then Cancel = True: Exit Sub
      317. End Sub
      319. Private Sub VariablenInitialisieren()
      321. 'intErkennung:
      322. '0 = Index
      323. '1 = Aenderungstext
      324. '2 = Datum
      325. '3 = User
      327. Dim i As Long
      329. txtInBearbeitung = ""
      330. varIndex = Aenderungen_Erfa_Bear_Index(0)
      332. If varIndex(1) = "F_F" Then
      333. Me.cmdEinfuegen_bea.Enabled = False
      334. Me.cmdInsert.Enabled = False
      335. Me.cmdAlles.Enabled = (Me.lsbAenderungen.ListIndex > -1)
      336. Me.cmdAlles.Enabled = False
      337. Me.cmdEdit.Enabled = False
      338. Me.cmdLoeschen.Enabled = False
      339. Me.cmdUndo.Enabled = False
      340. Me.cmdNeu.Enabled = False
      342. Me.txtNeu.Enabled = False
      343. Me.txtEdit.Enabled = False
      344. Me.cmdLoeschen.Enabled = False
      345. Me.DTPicker1.Enabled = False
      346. Me.DTPicker2.Enabled = False
      347. Me.DTPicker1.Value = Date
      348. Me.DTPicker2.Value = Date
      349. Me.Label1.Caption = "Eingetragen am"
      350. Me.Label3.Caption = "Geaendert am"
      352. Me.Label4.Caption = ""
      354. Me.OptionButton1.Value = False
      355. Me.OptionButton2.Value = False
      357. Me.OptionButton1.Enabled = False
      358. Me.OptionButton2.Enabled = False
      360. Me.lbDatumNeu.Caption = " D A T U M "
      361. Me.lbDatumVorh.Caption = ""
      362. Me.lbIndex.Caption = "I N D E X"
      363. Me.lbAenderungen.Caption = "A E N D E R U G S T E X T"
      365. Exit Sub
      367. End If
      368. varAender = Aenderungen_Erfa_Bear_Index(1)
      369. varDat = Aenderungen_Erfa_Bear_Index(2)
      370. varUser = Aenderungen_Erfa_Bear_Index(3)
      371. varDat_geaen = Aenderungen_Erfa_Bear_Index(4)
      372. varUser_geaen = Aenderungen_Erfa_Bear_Index(5)
      374. If varIndex(1) = "0_0" Then 'Liste ist leer
      376. Me.cmdEinfuegen_bea.Enabled = False
      377. Me.cmdInsert.Enabled = False
      378. Me.cmdAlles.Enabled = (Me.lsbAenderungen.ListIndex > -1)
      379. Me.cmdAlles.Enabled = False
      380. Me.cmdEdit.Enabled = False
      381. Me.cmdLoeschen.Enabled = False
      382. Me.cmdUndo.Enabled = False
      384. Me.OptionButton1.Value = False
      385. Me.OptionButton2.Value = False
      387. Me.OptionButton1.Enabled = False
      388. Me.OptionButton2.Enabled = False
      390. Me.txtNeu.Enabled = False
      391. Me.txtEdit.Enabled = False
      392. Me.cmdLoeschen.Enabled = False
      393. Me.DTPicker1.Enabled = False
      394. Me.DTPicker2.Enabled = False
      395. Me.DTPicker1.Value = Date
      396. Me.DTPicker2.Value = Date
      397. Me.Label1.Caption = "Eingetragen am"
      398. Me.Label3.Caption = "Geaendert am"
      399. Me.Label4.Caption = ""
      400. Me.lbDatumNeu.Caption = " D A T U M "
      401. Me.lbDatumVorh.Caption = ""
      402. Me.lbIndex.Caption = "I N D E X"
      403. Me.lbAenderungen.Caption = "A E N D E R U G S T E X T"
      405. Else
      407. For i = LBound(varIndex) + 1 To UBound(varIndex)
      408. If i >= 11 Then
      409. Me.lsbAenderungen.AddItem varIndex(i) & " " & Trim$(varAender(i)) '& " " & varDat(i)
      410. Else
      411. Me.lsbAenderungen.AddItem " " & varIndex(i) & " " & Trim$(varAender(i)) '& " " & varDat(i)
      412. End If
      413. Next
      415. Me.cmdEinfuegen_bea.Enabled = False
      416. Me.cmdInsert.Enabled = False
      417. Me.cmdAlles.Enabled = (Me.lsbAenderungen.ListIndex < 0)
      418. Me.cmdEdit.Enabled = False
      419. Me.cmdLoeschen.Enabled = False
      420. Me.cmdUndo.Enabled = False
      422. Me.OptionButton1.Value = False
      423. Me.OptionButton2.Value = False
      425. Me.OptionButton1.Enabled = False
      426. Me.OptionButton2.Enabled = False
      428. Me.txtNeu.Enabled = False
      429. Me.txtEdit.Enabled = False
      430. Me.DTPicker1.Enabled = False
      431. Me.DTPicker2.Enabled = False
      432. Me.DTPicker1.Value = Date
      433. ' Me.DTPicker2.Value = Date
      434. Me.Label1.Caption = "Eingetragen am"
      435. Me.Label3.Caption = "Geaendert am"
      436. Me.Label4.Caption = ""
      437. Me.lbDatumNeu.Caption = " D A T U M "
      438. Me.lbDatumVorh.Caption = ""
      439. Me.lbIndex.Caption = "I N D E X"
      440. Me.lbAenderungen.Caption = "A E N D E R U G S T E X T"
      441. Me.lsbAenderungen.Value = Me.lsbAenderungen.List(0)
      442. Me.lsbAenderungen.ControlTipText = "Klicken Sie doppelt auf die Zeile um alle Daten zu sehen."
      444. End If
      446. End Sub
      448. Private Sub Form_Clear()
      450. Me.lsbAenderungen.Clear
      452. Me.txtEdit.Value = ""
      453. Me.txtNeu.Value = ""
      454. Me.lbDatumVorh.Caption = ""
      455. Me.Label4.Caption = ""
      457. End Sub
      459. Private Sub AenderungsText_ZurueckSchreiben()
      461. Dim i As Integer, lgRow As Long
      462. Dim ws As Worksheet, wsActiv As Worksheet
      464. On Error GoTo ErrH
      466. Application.ScreenUpdating = False
      467. 'Verweis auf aktives Blatt
      468. Set wsActiv = Application.ActiveSheet
      469. 'Verweis auf Blatt aenderungen_erf
      470. Set ws = Application.ActiveWorkbook.Worksheets(strTabname)
      471. 'um einem ausgeblendeten Blatt zuzugreifen vorher Blatt aktivieren
      472. ws.Activate
      474. With ws
      475. lgRow = .Cells(Rows.Count, 1).End(xlUp).Row
      477. If lgRow > 1 Then 'mehr als eine Zeile
      478. 'Blatt ausräumen
      479. .Range(Cells(2, 1), Cells(lgRow, 6)).ClearContents
      480. 'vorher gespeicherten Werte zurueckschreiben
      481. For i = 1 To UBound(varStand_1_Index) - 1
      482. .Range(Cells(i + 1, 1), Cells(i + 1, 1)).Value = i
      484. .Range(Cells(i + 1, 2), Cells(i + 1, 2)).Value = varStand_1_Aender(i + 1)
      486. .Range(Cells(i + 1, 3), Cells(i + 1, 3)).Value = varStand_1_Dat(i + 1)
      488. .Range(Cells(i + 1, 4), Cells(i + 1, 4)).Value = varStand_1_User(i + 1)
      490. .Range(Cells(i + 1, 5), Cells(i + 1, 5)).Value = varStand_1_Datgeaen(i + 1)
      492. .Range(Cells(i + 1, 6), Cells(i + 1, 6)).Value = varStand_1_Usergeaen(i + 1)
      494. Next
      495. Else
      496. For i = 1 To UBound(varStand_1_Index) - 1
      497. .Range(Cells(i + 1, 1), Cells(i + 1, 1)).Value = i
      499. .Range(Cells(i + 1, 2), Cells(i + 1, 2)).Value = varStand_1_Aender(i + 1)
      501. .Range(Cells(i + 1, 3), Cells(i + 1, 3)).Value = varStand_1_Dat(i + 1)
      502. .Range(Cells(i + 1, 4), Cells(i + 1, 4)).Value = varStand_1_User(i + 1)
      503. .Range(Cells(i + 1, 5), Cells(i + 1, 5)).Value = varStand_1_Datgeaen(i + 1)
      504. .Range(Cells(i + 1, 6), Cells(i + 1, 6)).Value = varStand_1_Usergeaen(i + 1)
      506. Next
      508. End If
      509. End With
      511. Set ws = Nothing
      512. wsActiv.Activate
      513. Set wsActiv = Nothing
      514. Application.ScreenUpdating = True
      515. ErrH:
      516. If Err <> 0 Then
      517. MsgBox Err.Description, , "FEHLER"
      518. Set ws = Nothing
      519. wsActiv.Activate
      520. Set wsActiv = Nothing
      521. Application.ScreenUpdating = True
      522. End If
      524. End Sub
      526. Private Sub Text_Geaendert_Eintragen(intErkennung As Integer, intPos As Integer, Optional varDatumAenderung As Variant)
      528. Dim i As Integer, lgRow As Long, strUserName$
      529. Dim ws As Worksheet, wsActiv As Worksheet
      531. '0 = Texte geaendert Werte aus txtEdit
      532. '1= Texte neu
      535. On Error GoTo ErrH
      537. Application.ScreenUpdating = False
      538. 'Verweis auf aktives Blatt
      539. Set wsActiv = Application.ActiveSheet
      540. 'Verweis auf Blatt aenderungen_erf
      541. Set ws = Application.ActiveWorkbook.Worksheets(strTabname)
      542. 'um einem ausgeblendeten Blatt zuzugreifen vorher Blatt aktivieren
      543. ws.Activate
      545. strUserName = AnwenderName_Aktuell()
      547. lgRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
      549. With ws
      551. Select Case intErkennung
      553. Case 0 'geaenderte Texte
      554. 'Zeile ausräumen
      555. .Range(Cells(intPos + 2, 2), Cells(intPos + 2, 2)).ClearContents
      556. .Range(Cells(intPos + 2, 6), Cells(intPos + 2, 6)).ClearContents
      558. .Range(Cells(intPos + 2, 2), Cells(intPos + 2, 2)).Value = Me.txtEdit.Value
      559. '.Range(Cells(intPos + 2, 3), Cells(intPos + 2, 3)).Value = CStr(Me.DTPicker2.Value)
      560. .Range(Cells(intPos + 2, 6), Cells(intPos + 2, 6)).Value = strUserName
      562. If Not IsMissing(varDatumAenderung) Then
      563. Select Case varDatumAenderung
      564. Case 3
      565. .Range(Cells(intPos + 2, 3), Cells(intPos + 2, 3)).Value = CStr(Me.DTPicker2.Value)
      566. If .Range(Cells(intPos + 2, 5), Cells(intPos + 2, 5)).Value = "" Then
      567. .Range(Cells(intPos + 2, 5), Cells(intPos + 2, 5)).Value = CStr(Me.DTPicker2.Value)
      569. End If
      570. Case 5
      571. .Range(Cells(intPos + 2, 5), Cells(intPos + 2, 5)).Value = CStr(Me.DTPicker2.Value)
      572. If .Range(Cells(intPos + 2, 3), Cells(intPos + 2, 3)).Value = "" Then
      573. .Range(Cells(intPos + 2, 3), Cells(intPos + 2, 3)).Value = CStr(Me.DTPicker2.Value)
      574. End If
      576. End Select
      577. Else
      578. .Range(Cells(intPos + 2, 5), Cells(intPos + 2, 5)).Value = CStr(Me.DTPicker2.Value) 'ist es nicht überflüssig?
      579. End If
      580. Case 1 'Texte neu
      581. .Range(Cells(lgRow + 1, 1), Cells(lgRow + 1, 1)).Value = lgRow
      582. .Range(Cells(lgRow + 1, 2), Cells(lgRow + 1, 2)).Value = Me.txtNeu.Value
      583. .Range(Cells(lgRow + 1, 3), Cells(lgRow + 1, 3)).Value = CStr(Me.DTPicker1.Value)
      584. .Range(Cells(lgRow + 1, 4), Cells(lgRow + 1, 4)).Value = strUserName
      586. End Select
      588. End With
      590. Set ws = Nothing
      591. wsActiv.Activate
      592. Set wsActiv = Nothing
      593. Application.ScreenUpdating = True
      594. ErrH:
      595. If Err <> 0 Then
      596. MsgBox Err.Description, , "FEHLER"
      597. Set ws = Nothing
      598. wsActiv.Activate
      599. Set wsActiv = Nothing
      600. Application.ScreenUpdating = True
      601. End If
      603. End Sub
      605. Private Sub AenderungsBlattFormatieren()
      606. Dim i As Integer, lgRow As Long
      607. Dim ws As Worksheet, wsActiv As Worksheet
      608. Dim strPrintArea$
      610. On Error GoTo ErrH
      612. Application.ScreenUpdating = True
      613. DoEvents
      614. Me.Hide
      615. Application.ScreenUpdating = False
      616. 'Verweis auf aktives Blatt
      617. Set wsActiv = Application.ActiveSheet
      618. 'Verweis auf Blatt aenderungen_erf
      619. Set ws = Application.ActiveWorkbook.Worksheets(strTabname)
      620. 'um einem ausgeblendeten Blatt zuzugreifen vorher Blatt aktivieren
      621. ws.Activate
      623. Application.ScreenUpdating = False
      625. lgRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
      627. With ws
      628. 'Druckbereich zuweisen
      629. strPrintArea = .Range(Cells(1, 1), Cells(lgRow, 6)).Address
      631. 'alle Zellen haben Textformat
      632. .Range(Cells(1, 2), Cells(lgRow, 6)).NumberFormat = "@"
      633. 'in Spalte 2 ab Zeile 2 Zeilenumbruch
      634. .Range(Cells(2, 2), Cells(lgRow, 2)).WrapText = True
      636. 'von der ersten Spalte bis zu vierten Spalte
      637. .Range(Cells(1, 1), Cells(1, 6)).HorizontalAlignment = xlCenter
      638. .Range(Cells(1, 1), Cells(1, 6)).VerticalAlignment = xlBottom
      639. .Range(Cells(1, 1), Cells(1, 6)).Font.Name = "Arial"
      640. .Range(Cells(1, 1), Cells(1, 6)).Font.FontStyle = "Fett"
      641. .Range(Cells(1, 1), Cells(1, 6)).Font.Size = 10
      643. .Range(Cells(2, 1), Cells(lgRow, 1)).HorizontalAlignment = xlCenter
      644. .Range(Cells(2, 1), Cells(lgRow, 1)).VerticalAlignment = xlBottom
      646. .Range(Cells(2, 3), Cells(lgRow, 3)).HorizontalAlignment = xlRight
      647. .Range(Cells(2, 3), Cells(lgRow, 3)).VerticalAlignment = xlBottom
      649. .Range(Cells(2, 5), Cells(lgRow, 5)).HorizontalAlignment = xlRight
      650. .Range(Cells(2, 5), Cells(lgRow, 5)).VerticalAlignment = xlBottom
      652. .Range(Cells(2, 4), Cells(lgRow, 4)).HorizontalAlignment = xlRight
      653. .Range(Cells(2, 4), Cells(lgRow, 4)).VerticalAlignment = xlBottom
      655. .Range(Cells(2, 6), Cells(lgRow, 6)).HorizontalAlignment = xlRight
      656. .Range(Cells(2, 6), Cells(lgRow, 6)).VerticalAlignment = xlBottom
      658. .Range(Cells(1, 1), Cells(1, 1)).Value = "INDEX"
      659. .Range(Cells(1, 2), Cells(1, 2)).Value = "AENDERUNGSTEXT"
      660. .Range(Cells(1, 3), Cells(1, 3)).Value = "EINTRAG AM"
      661. .Range(Cells(1, 4), Cells(1, 4)).Value = "EINTRAG VON"
      663. .Range(Cells(1, 5), Cells(1, 5)).Value = "GEAENDERT AM"
      664. .Range(Cells(1, 6), Cells(1, 6)).Value = "GEAENDERT VON"
      666. 'Zeilenwerte
      667. .Rows("1:1").RowHeight = 17
      668. .Rows("2:400").RowHeight = 45
      669. 'Spaltenwerte
      670. .Columns("A:A").ColumnWidth = 6
      671. .Columns("B:B").ColumnWidth = 68
      672. .Columns("C:C").ColumnWidth = 15
      673. .Columns("D:D").ColumnWidth = 18
      675. .Columns("E:E").ColumnWidth = 15
      676. .Columns("F:F").ColumnWidth = 18
      678. .Range("A1").Select
      680. 'Drucken
      681. With ActiveSheet.PageSetup
      682. .PrintTitleRows = "$1:$1"
      683. ' .PrintArea = ""
      684. .PrintArea = strPrintArea
      685. ' .PrintTitleColumns = ""
      686. .PrintGridlines = True
      688. .LeftHeader = "&D &T"
      689. .CenterHeader = ActiveWorkbook.Name
      690. ' .RightHeader = ""
      691. ' .LeftFooter = ""
      692. .CenterFooter = ActiveWorkbook.FullName
      693. .RightFooter = "&P& /&N"
      694. .LeftMargin = Application.CentimetersToPoints(1.4)
      695. .RightMargin = Application.CentimetersToPoints(1.4)
      696. .TopMargin = Application.CentimetersToPoints(2#)
      697. .BottomMargin = Application.CentimetersToPoints(2#)
      698. .HeaderMargin = Application.CentimetersToPoints(1.2)
      699. .FooterMargin = Application.CentimetersToPoints(1.2)
      700. ' .PrintHeadings = False
      701. ' .PrintComments = xlPrintNoComments
      702. .CenterHorizontally = True
      703. ' .CenterVertically = False
      704. .Orientation = xlLandscape
      705. ' .Draft = False
      706. .PaperSize = xlPaperA4
      707. ' .FirstPageNumber = xlAutomatic
      708. ' .Order = xlDownThenOver
      709. ' .BlackAndWhite = False
      710. .Zoom = 95
      711. '.PrintErrors = xlPrintErrorsDisplayed
      712. End With
      713. ' '.PrintOut
      715. End With
      717. Set ws = Nothing
      718. wsActiv.Activate
      719. Set wsActiv = Nothing
      720. Application.ScreenUpdating = True
      723. ErrH:
      724. If Err <> 0 Then
      725. MsgBox Err.Description, , "FEHLER"
      726. Set ws = Nothing
      727. wsActiv.Activate
      728. Set wsActiv = Nothing
      729. Application.ScreenUpdating = True
      730. End If
      732. End Sub


      Der Code ist unter Excel 2003/2010/2013 (deutsche Version) 32bit lauffähig.

      Ich wünsche euch viel Spaß damit.

      Edit by ~blaze~:
      *Code durch VB-Tag ersetzt*
      aufgrund des Datenumfangs Spoiler hinzugefügt ~VaporiZed

      Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „VaporiZed“ ()

    Facebook
    Telefonspende