Thema Datum  Von Nutzer Rating
Antwort
31.05.2017 19:24:10 Vale
NotSolved
05.06.2017 18:14:05 BigBen
NotSolved
06.06.2017 18:40:51 Vale
NotSolved
Blau Namen von Arbeitsmappe "X" in Arbeitsmappe "Y" kopieren, wenn nicht vorhanden
07.06.2017 07:21:36 BigBen
Solved
07.06.2017 18:59:42 Vale
NotSolved

Ansicht des Beitrags:
Von:
BigBen
Datum:
07.06.2017 07:21:36
Views:
592
Rating: Antwort:
 Nein
Thema:
Namen von Arbeitsmappe "X" in Arbeitsmappe "Y" kopieren, wenn nicht vorhanden

Hallo,

da hätte ich mir vieles Ersparen können. Nun gut.

Damit man künftig die Übersicht von den Teilnehmern unterscheiden kann, bekommen die Tabellen eine neue Eigenschaft namens "Type":

Type = "Teilnehmer"

Alle Tabellen mit dieser CustomProperty werden als Teilnehmer-Tabelle behandelt.

Type = "Übersicht"

In der Arbeitsmappe darf nur eine Tabelle mit diesem Typ vorhanden sein. Falls dennoch mehrere vorhanden sein sollten, wird nur die erste Tabelle als Übersicht behandelt.

Die Umsetzung erfolgt in VBA wie folgt:

Code in DieseArbeitsmappe

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim sTyp As String
    Dim rngNew As Range
    Dim wsh As Worksheet
    If VBA.TypeName(Sh) = "Worksheet" Then
        Set wsh = Sh
        sTyp = CustomProperty(wsh, "Type")
        Select Case sTyp
            Case "Teilnehmer"
                 For Each rngNew In Target.Cells
                    If rngNew.Row >= 4 Then
                        ' Existiert der gesuchte Eintrag in einer anderen Zelle?
                        If WorksheetFunction.CountIf(Target.Worksheet.Range("A4:A1048576"), rngNew.Value) = 1 Then
                            FillOverviewWorksheet rngNew.Value
                        End If
                    End If
                Next
            Case Else
        End Select
    End If
End Sub

Property Let CustomProperty(wsh As Worksheet, sName As String, sValue As String)
    Dim iProp As Integer
    Dim bFound As Boolean
    With wsh
        For iProp = 1 To wsh.CustomProperties.Count
            With .CustomProperties.Item(iProp)
                If .Name = sName Then
                    If sValue = "" Then
                        .Delete
                    Else
                        .Value = sValue
                    End If
                    bFound = True
                    Exit For
                End If
            End With
        Next
        If Not bFound And Not sValue = "" Then
            .CustomProperties.Add Name:=sName, Value:=sValue
        End If
    End With
End Property

Property Get CustomProperty(wsh As Worksheet, sName As String) As String
    Dim iProp As Integer
    Dim bFound As Boolean
    With wsh
        For iProp = 1 To wsh.CustomProperties.Count
            With .CustomProperties.Item(iProp)
                If .Name = sName Then
                    CustomProperty = .Value
                    Exit For
                End If
            End With
        Next
    End With
End Property

Function SearchWorksheetsCustomProperty(sName As String, sValue As String) As Worksheet
    Dim wsh As Worksheet
    For Each wsh In ThisWorkbook.Worksheets
        If CustomProperty(wsh, sName) = sValue Then
            Set SearchWorksheetsCustomProperty = wsh
            Exit For
        End If
    Next
End Function

Private Sub FillOverviewWorksheet(Value As String)
    Dim rng As Range
    Dim rngCheck As Range
    Dim wsh As Worksheet
    Set wsh = SearchWorksheetsCustomProperty("Type", "Übersicht")
    'Set wsh = ThisWorkbook.Worksheets("TabU")
    If Not wsh Is Nothing Then
        Set rng = wsh.Range("A10:A1048576")
        If rng.Find(what:=Value) Is Nothing Then
            ' Freie Zelle finden
            For Each rngCheck In rng.Cells
                If IsEmpty(rngCheck) Then
                    Exit For
                End If
            Next
            ' Neuen Eintrag anlegen
            If Not rngCheck Is Nothing Then
                rngCheck.Value = Value
            End If
        End If
    End If
End Sub

Code in einem Modul

Sub SetTypes()
    Dim wsh As Worksheet
    Set wsh = ThisWorkbook.Worksheets("TabU")
    ThisWorkbook.CustomProperty(wsh, "Type") = "Übersicht"

    Set wsh = ThisWorkbook.Worksheets("TabA")
    ThisWorkbook.CustomProperty(wsh, "Type") = "Teilnehmer"
    
    Set wsh = ThisWorkbook.Worksheets("TabB")
    ThisWorkbook.CustomProperty(wsh, "Type") = "Teilnehmer"
    
End Sub

Erläuterung:

Angenommen, in der Arbeitsmappe existieren drei Tabellen:

TabA
TabB
TabU

Beim Ausführen des Befehls "SetTypes" werden die Tabellen "TabA" und "TabB" als "Teilnahmer" eingestuft.
Die Tabelle "TabU" bekommt als einzigste Tabelle den Typ "Übersicht".

Falls neue Teilnehmer-Tabellen hinzugefügt werden sollen, müssen diese erst durch die Zuweisung des Typs "Teilnehmer" als solches gekennzeichnet werden.

    ThisWorkbook.CustomProperty(ThisWorkbook.Worksheets("Tabellenname"), "Type") = "Teilnehmer"

Falls bei einer Tabelle versehentlich ein Typ zugewisen wurde, kann der Typ wieder entfernt werden:

    ThisWorkbook.CustomProperty(ThisWorkbook.Worksheets("Tabellenname"), "Type") = ""

Eine Muster-Arbeitsmappe kann hier heruntergeladen werden.

LG, BigBen


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
31.05.2017 19:24:10 Vale
NotSolved
05.06.2017 18:14:05 BigBen
NotSolved
06.06.2017 18:40:51 Vale
NotSolved
Blau Namen von Arbeitsmappe "X" in Arbeitsmappe "Y" kopieren, wenn nicht vorhanden
07.06.2017 07:21:36 BigBen
Solved
07.06.2017 18:59:42 Vale
NotSolved