VBA-Software - GVXnet

Direkt zum Seiteninhalt

VBA-Software

Software
VBA-Script für Excel
Das Script schreibt das aktuelle Datum und Uhrzeit in die ausgewählten Zellen.
Wenn die Zellen bereits Inhalte haben, werden diese in die Kommentar verschoben.
Werden zusammenhängende Felder angewählt, so fragt das Programm ob die Arrays gefüllt werden sollen. Das dient zur Sicherheit, denn es kann versehentlich eine ganze Zeile angewählt werden.
Es werden nur die sichtbare Zellen beschrieben. Bei Arrays werden nämlich auch die ausgeblendeten Zellen markiert.
Die Ausfürung des Scripts kann nicht rückgängig gemacht werden, deshalb sollte man vorher eine Kopie der activen Datei peichern, dadurch erfolgt keine Änderung des Dateinamens.

viel Spaß
Option Explicit

Sub DatumInZellenSchreiben()
'
' Selektierter Bereich wird mit aktuellem Datum und Zeit als fester Text beschrieben. Nicht wie bei der Tastenkombination "STRG+."
' VBA Funktionen können nicht rückgängig gemacht werden, deshalb sollte man vorher das workbook speichern
' Die Speicherung erfolgt automatisch bevor ein Array befüllt werden soll
' Arrays existieren z.B. wenn eine ganze Zeile markiert ist, deshalb wird auf Array abgefragt und nicht auf mehrere ausgewählte Zellen
' Für die Abfrage auf mehrere nicht zusammenhängende Zellen kann "Selection.Count > 1" verwendet werden
' Now - aktuelles Datum & Zeit
' Format(Now, "yymmddhhmmss")

  Dim strDatumFuellen_Antwort As String      ' Antwort der Messagebox mit Auswahl
  Dim bolFillCells As Boolean                ' Wenn true dann soll die Zelle gefüllt werden
   
  strDatumFuellen_Antwort = ""
  bolFillCells = False
      
  ' Ein Feld oder mehrere einzelne Felder ausgewählt ?
  If IsArray(Selection) = False Then bolFillCells = True

  If IsArray(Selection) = True Then       ' Wenn ein Array ausgewählt ist, nachfragen ob es gefüllt werden soll
      strDatumFuellen_Antwort = MsgBox("Aktuelles Datum in ein Array einfügen?", 1) ' Requester mit Ja/Abbruch
      
      If strDatumFuellen_Antwort = 1 Then bolFillCells = True ' wenn "Ja"
                
  End If
 
 If bolFillCells = True Then
      SaveActiveWorkbookCopy                 ' Kopie der Datei speichern
      Feldinhalt_In_Kommentare_Selection_NOW ' Text in Kommentare anschließend mit "NOW" füllen
 End If

End Sub

Sub Feldinhalt_In_Kommentare_Selection_NOW()
' Der Inhalt des aktuellen Feldes wird in ein Kommentar geschrieben
' Das Feld wird mit aktuellem Datum und Zeit beschrieben
' Aufruf der Funktion HiddenCells(rngcells) as boolean, mit dem Parameter der aktiven Zelle ob Zelle sichtbar oder versteckt
' Abfrage ob aktuelle Zelle sichtbar, Rückgabeparamter Wahr für sichtbar

  Dim rngCells As Range
  Dim strUsername As String
  
  strUsername = Environ("username")
  
  AutoUpdate_OFF
  
  For Each rngCells In Selection
  
    If HiddenCells(rngCells) = False Then
  
      If rngCells.Value = "" Then
          rngCells.Value = Now
          Else
  
          If rngCells.Comment Is Nothing Then ' Kommentar nicht vorhanden
              rngCells.AddComment
              rngCells.Comment.Visible = False
              rngCells.Comment.Text Text:=strUsername & ":" & Chr(10) & rngCells.Value
              rngCells.Value = Now
              Else
              
                  If Not rngCells Is Nothing Then ' Kommentar vorhanden
                      rngCells.Comment.Visible = False
                      rngCells.Comment.Text Text:=strUsername & ":" & Chr(10) & rngCells.Value & ";" & Chr(10) & rngCells.Comment.Text
                      rngCells.Value = Now
                  End If
          End If
      End If
   End If
  Next
  
  AutoUpdate_ON

End Sub

Function HiddenCells(rngCells As Range) As Boolean

' gibt den Boolwert "TRUE" zurück wenn die aktive Zelle augeblendet ist

  HiddenCells = False
  
  If rngCells.EntireRow.Hidden = True Then HiddenCells = True
  If rngCells.EntireColumn.Hidden = True Then HiddenCells = True

End Function

Sub AutoUpdate_ON()

  Application.Calculation = xlAutomatic
  Application.ScreenUpdating = True

End Sub

Sub AutoUpdate_OFF()

  Application.Calculation = xlManual
  Application.ScreenUpdating = False
End Sub

Sub SaveActiveWorkbookCopy()

   Dim strFilename_Left As String          ' der Dateiname ohne Erweiterung
   Dim strFilename_Extension As String     ' Erweiterung
   Dim strFilesavename As String           ' kompletter Name
   Dim strBackupPfad As String
   Dim strFileCompleteName As String
   Dim strAktuellesVerzeichnis As String
   
   strAktuellesVerzeichnis = ActiveWorkbook.Path
   strBackupPfad = "Backup\"
   If strAktuellesVerzeichnis <> "" Then ' Weiter, wenn Datei auf Speichermedium existiert
       If Dir(strAktuellesVerzeichnis & "\Backup", vbDirectory) = "" Then MkDir (strAktuellesVerzeichnis & "\Backup")
       
       strFilename_Extension = (Right(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - InStrRev(ActiveWorkbook.Name, ".")))
       strFilename_Left = (Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1))
       strFilesavename = (strFilename_Left & "-" & Format(Now, "yymmddhhmmss") & "." & strFilename_Extension)
       
       strFileCompleteName = strAktuellesVerzeichnis & "\" & strBackupPfad & strFilesavename
       ActiveWorkbook.SaveCopyAs (strFileCompleteName) ' Datei speichern
 
   End If

End Sub


Das Script erstellt Hyperlinks aus dem Feldinhalt.
Sub HyperlinkErstellenAktuelleZelle()
' Erstellt Hyperlinks der selektierten Felder
' Die Hyperlinks werden aus dem Eigenen Inhalt der Felder erstellt
' Diese Funktion ist interessant, weil bei Verknüpfungen zu einem andern Tabellenblatt
' der Text angezeigt wird, aber nicht der Link

   Dim rngCells As Range
   Dim spalte As Integer
   Dim Reihe As Integer
       
   SaveActiveWorkbookCopy
       
   AutoUpdate_OFF
       
   For Each rngCells In Selection
       If rngCells.Value <> "" Then ' Prüft ob aktuelle Zelle Inhalt hat
           If HiddenCells(rngCells) = False Then
               With ActiveSheet
               .Hyperlinks.add Anchor:=rngCells, Address:=rngCells.Value, ScreenTip:=rngCells.Value, TextToDisplay:=rngCells.Value
               End With
           End If
       End If
   Next
   
   AutoUpdate_ON

End Sub
Zurück zum Seiteninhalt