Autom Spaltenerstellung aus Schlagwortserie

Hallo zusammen,
ich habe folgendes Problem: ich habe ca. 500 Bilder, welche alle mit einer Vielzahl verschiedener IPTC Schlagworte aus einer Gesamtschlagwortmenge von ca. 150 Schlagworten belegt sind. In einem ersten Schritt habe ich diese Schlagworte in eine vorläufige Excel-Tabelle exportiert, die ihr unten vereinfacht sehen könnt, wenn ihr wollt, kann ich auch einen Ausschnitt aus dem Original hochladen. Alle Schlagworte sind hier mit einem Komma voneinander getrennt (es existieren alle Schlagworte nur einmal). Nun möchte ich in irgendeiner Weise erreichen, dass Excel für alle möglichen Schlagworte am besten automatisch eine einzelne Spalte eröffnet die entweder bestätigt oder nicht bestätigt werden kann und dann für jedes Bild (also jede Zeile), für welche das Schlagwort erwähnt ist, selbiges bestätigt. Alternativ liegen die Daten auch noch in den IPTC-Bilddaten vor, wenn jmd. dazu etwas besseres einfällt.
Um es mal etwas plastischer zu machen hier ein stark vereinfachtes Beispiel:
1. Spalte........2. Spalte
Bild_22...........Hase,Fuchs,Mord
Bild_11...........Hase,Igel,Kuss
Bildname...Hase...Fuchs...Mord...Igel...Kuss
Bild_22......ja.......ja........ja........nein...nein
Bild_11......ja.......nein.....nein.....ja......ja
Für Hilfestellungen wäre ich sehr dankbar!
Lg,
Franziska

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Franziska,
probier mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub keywords()
  Dim objSh As Worksheet, objShSrc As Worksheet
  Dim vntKeywords() As Variant, vntTmp As Variant
  Dim lngRow As Long, lngIndex As Long

  Redim vntKeywords(0)

  Set objShSrc = Sheets("Tabelle1")

  With objShSrc
    For lngRow = 2 To Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
      vntTmp = Split(.Cells(lngRow, 2), ",")
      For lngIndex = 0 To UBound(vntTmp)
        If IsError(Application.Match(vntTmp(lngIndex), vntKeywords, 0)) Then
          vntKeywords(UBound(vntKeywords)) = vntTmp(lngIndex)
          Redim Preserve vntKeywords(UBound(vntKeywords) + 1)
        End If
      Next
    Next
  End With

  Redim Preserve vntKeywords(UBound(vntKeywords) - 1)

  If UBound(vntKeywords) > 0 Then
    If SheetExist("Keywords") Then
      Set objSh = Sheets("Keywords")
      objSh.Cells.Clear
      objSh.Activate
    Else
      Set objSh = ThisWorkbook.Worksheets.Add(After:=objShSrc)
      objSh.Name = "Keywords"
    End If
    With objSh
      .Columns(1) = objShSrc.Columns(1).Value
      With .Cells(1, 2).Resize(, UBound(vntKeywords) + 1)
        .Value = Application.Transpose(Application.Transpose(vntKeywords))
        .Orientation = 90
        .EntireColumn.AutoFit
        .EntireColumn.HorizontalAlignment = xlCenter
      End With
      For lngRow = 2 To Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
        vntTmp = Split(objShSrc.Cells(lngRow, 2), ",")
        For lngIndex = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
          If IsNumeric(Application.Match(.Cells(1, lngIndex), vntTmp, 0)) Then
            .Cells(lngRow, lngIndex) = "x"
          End If
        Next
      Next
    End With
  End If

  Set objSh = Nothing
  Set objShSrc = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Autom Spaltenerstellung aus Schlagwortserie

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread