Thema Datum  Von Nutzer Rating
Antwort
22.07.2017 15:05:37 Carsten
NotSolved
22.07.2017 19:08:21 Gast70117
NotSolved
23.07.2017 13:40:22 Gast55051
NotSolved
24.07.2017 06:57:30 Gast70117
NotSolved
Rot Trim Cells anhand von 2 Bedingungen
22.07.2017 19:21:04 Ben
Solved
23.07.2017 13:42:34 Carsten
NotSolved
23.07.2017 15:41:41 Ben
Solved
24.07.2017 08:25:34 Carsten
NotSolved

Ansicht des Beitrags:
Von:
Ben
Datum:
22.07.2017 19:21:04
Views:
721
Rating: Antwort:
 Nein
Thema:
Trim Cells anhand von 2 Bedingungen

Hallo Carsten,

vielleicht ist folgender Code hilfreich:

Sub VerketteBinC()
    Dim wsh As Worksheet
    Dim rngRow As Range
    Dim rngDataRow As Range
    Dim colData As New Collection
    Set wsh = ActiveWorkbook.Worksheets(1)
    
    For Each rngRow In wsh.UsedRange.Rows
        If rngRow.Row > 1 Then ' Überschrift überspringen
            If Not IsEmpty(rngRow.Cells(1, 1).Value) Then
                SaveData rngDataRow, colData
                Set rngDataRow = rngRow
                Set colData = New Collection
            ElseIf Not rngDataRow Is Nothing Then
                AddItem colData, rngRow.Cells(1, 2), rngRow.Cells(1, 3)
            End If
                
        End If
    Next
    SaveData rngDataRow, colData
End Sub

Sub SaveData(ByRef rng As Range, ByRef colData As Collection)
    Dim iCol As Integer
    Dim sColName As String
    If Not rng Is Nothing Then
        For iCol = 1 To colData.Count
            For iColumn = 1 To rng.Columns.Count
                If rng.Worksheet.Cells(1, iColumn).Value = colData.Item(iCol).Item(1) Then
                    rng.Cells(1, iColumn) = colData.Item(iCol).Item(2)
                    Exit For
                End If
            Next
        Next
    End If
End Sub

Sub AddItem(ByRef colData As Collection, ByVal sTag As String, sValue As String)
    Dim iCol As Integer
    Dim colItem As New Collection
    colItem.Add Item:=sTag
    For iCol = 1 To colData.Count
        If colData.Item(iCol).Item(1) = colItem.Item(1) Then
            sValue = colData.Item(iCol).Item(2) & ", " & sValue
            colData.Remove (iCol)
            Exit For
        End If
    Next
    colItem.Add Item:=sValue
    colData.Add colItem
End Sub

Kurze Erläuterung:

Die eingelesenen Einträge landen in einer verschachtelten Collection.

Jeder Eintrag hat zwei Werte tag und value.

Falls ein tag beim neu Hinzufügen eines neuen Eintrags bereits existiert, wird der value-Eintrag ergänzt.

In der Sub SaveData werden die gesammelten Einträge in der Collection in der Tabelle gespeichert.

Hierbei werden die Überschriften in Zeile 1 durchaufen und mit dem gespeicherten Tag-Wert vergleichen. Nur bei Übereinstimmung werden die Werte in der Tabelle geschrieben.

Falls weitere Tags hinzukommen sollten, braucht nur die Überschriten-Zeile ergänzt werden.

LG, Ben


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
22.07.2017 15:05:37 Carsten
NotSolved
22.07.2017 19:08:21 Gast70117
NotSolved
23.07.2017 13:40:22 Gast55051
NotSolved
24.07.2017 06:57:30 Gast70117
NotSolved
Rot Trim Cells anhand von 2 Bedingungen
22.07.2017 19:21:04 Ben
Solved
23.07.2017 13:42:34 Carsten
NotSolved
23.07.2017 15:41:41 Ben
Solved
24.07.2017 08:25:34 Carsten
NotSolved