Kommentare über mehrere Spalten auslesen

Sub readComments() Dim rngC As Range, rng As Range On Error Resume Next Set rngC = ActiveCell.EntireColumn.SpecialCells(xlCellTypeComments) On Error GoTo 0 If Not rngC Is Nothing Then Columns(ActiveCell.Column + 1).Insert For Each rng In rngC.Cells rng.Offset(0, 1) = rng.Comment.Text Next End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Constantin,

' **********************************************************************
' Modul: Modul2  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub readComments()
  Dim rng As Range, rngC As Range
  Dim lngIndex As Long, lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  lngIndex = 3
  
  With ActiveSheet
    Do While .Cells(1, lngIndex) <> ""
      Set rngC = Nothing
      .Columns(lngIndex + 1).Insert
      .Cells(1, lngIndex + 1) = "NEU_" & .Cells(1, lngIndex)
      On Error Resume Next
      Set rngC = .Columns(lngIndex).SpecialCells(xlCellTypeComments)
      On Error GoTo 0
      If Not rngC Is Nothing Then
        For Each rng In rngC.Cells
          rng.Offset(0, 1) = rng.Comment.Text
        Next
      End If
      lngIndex = lngIndex + 2
    Loop
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'readComments'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Prozedur - readComments"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  Set rng = Nothing
  Set rngC = Nothing
End Sub


Sub hide_NEU()
  Dim rngHide As Range
  Dim lngCol As Long
  
  For lngCol = 4 To Application.Max(4, Cells(1, Columns.Count).End(xlToLeft).Column)
    If Cells(1, lngCol) Like "NEU_*" Then
      If rngHide Is Nothing Then
        Set rngHide = Columns(lngCol)
      Else
        Set rngHide = Union(rngHide, Columns(lngCol))
      End If
    End If
  Next
  
  If Not rngHide Is Nothing Then rngHide.EntireColumn.Hidden = True
End Sub


Sub show_NEU()
  Dim rngHide As Range
  Dim lngCol As Long
  
  For lngCol = 4 To Application.Max(4, Cells(1, Columns.Count).End(xlToLeft).Column)
    If Cells(1, lngCol) Like "NEU_*" Then
      If Application.CountA(Columns(lngCol)) > 1 Then
        If rngHide Is Nothing Then
          Set rngHide = Columns(lngCol)
        Else
          Set rngHide = Union(rngHide, Columns(lngCol))
        End If
      End If
    End If
  Next
  
  If Not rngHide Is Nothing Then rngHide.EntireColumn.Hidden = False
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Kommentare über mehrere Spalten auslesen

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

342 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kommentare über mehrere Spalten auslesen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

342 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread