Benutzer:Gerold Broser/Früchtecocktailshaker

Marias Version

Option Explicit

'--------------------------------------------------
'Change these according to your actual sheets

Const INPUT_SHEET_NAME = "Wertetabelle"
Const INPUT_COLUMN_INDEX = 6
Const INPUT_ITEM_SEPARATOR = ";"
Const INPUT_ITEMS_MAX = 1000

Const LIST_SHEET_NAME = "Schlagwortliste"
Const LIST_COLUMN_INDEX = 3
Const LIST_ROW_INDEX = "6"


'--------------------------------------------------
'

'
' SchlagwortlisteErzeugen()
' ===================================

' 2009-06-20 by Geri Broser

' Looks through all cells of the INPUT_COLUMN_INDEX column in INPUT_SHEET_NAME.
' Distinct items in the cells, separated by ITEM_SEPARATOR,
' are put to the LIST_COLUMN_INDEX column of LIST_SHEET_NAME.
' Spaces around the items are trimmed off.

Public Sub SchlagwortlisteErzeugen()

  Dim inputSheet As Worksheet
  Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET_NAME)
  
  Dim rowIdx As Long
  Dim cellText As String
  Dim itemsInCell() As String
  Dim Item As Variant
  Dim items() As String  'array to hold all items
  Dim nextItemIdx As Long
  nextItemIdx = 0
 
  'clear below headlines
  Range("B6:C2000").ClearContents
  
  'loop through all cells
  For rowIdx = LIST_ROW_INDEX To INPUT_ITEMS_MAX
    cellText = inputSheet.Cells(rowIdx, INPUT_COLUMN_INDEX)
    If cellText <> vbNullString Then
      'get items within cell and add them to items array
      itemsInCell = Split(cellText, INPUT_ITEM_SEPARATOR)
      For Each Item In itemsInCell
        ReDim Preserve items(nextItemIdx)
        items(nextItemIdx) = Trim(Item)
        nextItemIdx = nextItemIdx + 1
      Next Item
    End If
  Next rowIdx
  
  Call QuickSort(items)
  
  Call putItemsToListSheet(items)
  
End Sub 'Schlagwortliste()
'

' putItemsToListSheet()
' =====================

Private Sub putItemsToListSheet(items)

  Dim listSheet As Worksheet
  Set listSheet = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)

  Dim rowIdx As Long

  Dim Item As Variant
  
  rowIdx = LIST_ROW_INDEX
  Dim previousItem As String
  For Each Item In items
'    If Item <> vbNullString Then
     If Item <> previousItem Then
      listSheet.Cells(rowIdx, LIST_COLUMN_INDEX) = Item
      rowIdx = rowIdx + 1
     End If
    previousItem = Item
  Next Item

End Sub



'From: http://www.vbarchiv.net/tipps/details.php?id=372

' QuickSort-Algorithmus
'
' vSort() : zu sortierendes Array
' lngStart, lngEnd: zu sortierender Bereich
' ==========================================
Private Sub QuickSort(vSort As Variant, _
  Optional ByVal lngStart As Variant, _
  Optional ByVal lngEnd As Variant)
 
  ' Wird die Bereichsgrenze nicht angegeben,
  ' so wird das gesamte Array sortiert
 
  If IsMissing(lngStart) Then lngStart = LBound(vSort)
  If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
 
  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant
 
  i = lngStart: j = lngEnd
  x = vSort((lngStart + lngEnd) / 2)
 
  ' Array aufteilen
  Do
 
    While (vSort(i) < x): i = i + 1: Wend
    While (vSort(j) > x): j = j - 1: Wend
 
    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      h = vSort(i)
      vSort(i) = vSort(j)
      vSort(j) = h
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)
 
  ' Rekursion (Funktion ruft sich selbst auf)
  If (lngStart < j) Then QuickSort vSort, lngStart, j
  If (i < lngEnd) Then QuickSort vSort, i, lngEnd
  
End Sub 'QuickSort()

Geris Version

' createDistinctItemsList
' =======================

' 2009-06-22 by Geri Broser

Option Explicit
Option Compare Text

'--------------------------------------------------
'Change these according to your actual sheets

Const INPUT_SHEET = "Wertetabelle"
Const INPUT_NAME_COLUMN = 5  'Note:
Const INPUT_ITEMS_COLUMN = 6  'NAME and ITEMS columns must not be the same
Const INPUT_ITEMS_SEPARATOR = ";"
Const INPUT_BEGIN_ROW = 1
Const INPUT_END_ROW = 1000

Const OUTPUT_SHEET = "Schlagwortliste"
Const OUTPUT_ITEM_COLUMN = 3  'Note:
Const OUTPUT_NAMES_COLUMN = 4 'ITEM and NAMES columns must not be the same
Const OUTPUT_NAMES_SEPARATOR = ", "
Const OUTPUT_BEGIN_ROW = 6
'--------------------------------------------------
'

Public Sub SchlagwortlisteErzeugen()

  Call createDistinctItemsListCompletely
  
End Sub
'

' createDistinctItemsListQuickly()
'=================================

' 2009-06-22 by Geri Broser

' Looks through the cells of INPUT_ITEMS_COLUMN in INPUT_SHEET,
' beginning at the first non-empty cell equal or greater than INPUT_BEGIN_ROW,
' ending at the first empty cell or at INPUT_END_ROW.
' Distinct items in these cells, separated by INPUT_ITEMS_SEPARATOR, are put to
' OUTPUT_ITEM_COLUMN in OUTPUT_SHEET, beginning at OUTPUT_BEGIN_ROW.
' Spaces around the items are trimmed off.

Private Sub createDistinctItemsListQuickly()

  Dim items() As String
  Dim beginRowIdx As Long
  Dim rowIdx As Long
  
  items = getItemsQuickly(beginRowIdx, rowIdx)
  
  Call QuickSort(items)
  
  Call putDistinctItemsToOutputSheet(items)
  
  Call createNamesListsInOutputSheet(beginRowIdx, rowIdx - 1)
  
End Sub
'

' createDistinctItemsListCompletely()
' ===================================

' 2009-06-22 by Geri Broser

' Looks through all cells of INPUT_ITEMS_COLUMN in INPUT_SHEET,
' from INPUT_BEGIN_ROW to INPUT_END_ROW.
' Distinct items in these cells, separated by INPUT_ITEMS_SEPARATOR, are put to
' OUTPUT_ITEM_COLUMN in OUTPUT_SHEET, beginning at OUTPUT_BEGIN_ROW.
' Spaces around the items are trimmed off.

Private Sub createDistinctItemsListCompletely()

  Dim items() As String
  
  items = getItemsCompletely()
  
  Call QuickSort(items)
  
  Call putDistinctItemsToOutputSheet(items)
  
  Call createNamesListsInOutputSheet(INPUT_BEGIN_ROW, INPUT_END_ROW)
  
End Sub
'

' getItemsQuickly()
' =================

' 2009-06-22 by Geri Broser

Private Function getItemsQuickly(ByRef beginRowIdx As Long, ByRef rowIdx As Long) As String()

  Dim inputSheet As Worksheet
  Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET)
  
  Dim itemsList As String
  Dim itemsInList() As String  'array to hold items in one list (one cell)
  Dim item As Variant
  Dim items() As String  'array to hold all items
  ReDim Preserve items(0)
  
  'get first non-empty cell
  rowIdx = INPUT_BEGIN_ROW - 1
  Do
    rowIdx = rowIdx + 1
    itemsList = inputSheet.Cells(rowIdx, INPUT_ITEMS_COLUMN)
  Loop Until itemsList <> vbNullString
  beginRowIdx = rowIdx
  itemsInList = Split(itemsList, INPUT_ITEMS_SEPARATOR)
  Dim itemIdx As Long
  itemIdx = 0
  ReDim Preserve items(UBound(itemsInList))
  
  'loop through cells until first empty cell
  Do While itemsList <> vbNullString And rowIdx <= INPUT_END_ROW
    
    'get items within cell and add them to items
    For Each item In itemsInList
      items(itemIdx) = Trim(item)
      itemIdx = itemIdx + 1
    Next item
      
    'get next cell
    rowIdx = rowIdx + 1
    itemsList = inputSheet.Cells(rowIdx, INPUT_ITEMS_COLUMN)
    itemsInList = Split(itemsList, ",")
    itemIdx = UBound(items) + 1
    ReDim Preserve items(itemIdx + UBound(itemsInList))
    
  Loop
  
  getItemsQuickly = items

End Function 'getItemsQuickly()
'

' getItemsCompletely()
' ====================

' 2009-06-22 by Geri Broser

Private Function getItemsCompletely() As String()

  Dim inputSheet As Worksheet
  Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET)
  
  Dim rowIdx As Long
  Dim itemsList As String
  Dim itemsInList() As String  'array to hold items in one list (one cell)
  Dim item As Variant
  Dim items() As String  'array to hold all items
  Dim itemIdx As Long
  
  itemIdx = 0
    
  'loop through all cells
  For rowIdx = INPUT_BEGIN_ROW To INPUT_END_ROW
    itemsList = inputSheet.Cells(rowIdx, INPUT_ITEMS_COLUMN)
    If itemsList <> vbNullString Then
      'get items within cell and add them to items array
      itemsInList = Split(itemsList, INPUT_ITEMS_SEPARATOR)
      For Each item In itemsInList
        ReDim Preserve items(itemIdx)
        items(itemIdx) = Trim(item)
        itemIdx = itemIdx + 1
      Next item
    End If
  Next rowIdx
  
  getItemsCompletely = items
  
End Function 'getItemsCompletely()
'

' putDistinctItemsToOutputSheet()
' ===============================

' 2009-06-20 by Geri Broser

Private Sub putDistinctItemsToOutputSheet(items)

  Dim outputSheet As Worksheet
  Set outputSheet = ActiveWorkbook.Worksheets(OUTPUT_SHEET)
  
  'clear output range
  outputSheet.Activate
  outputSheet.Range(outputSheet.Cells(OUTPUT_BEGIN_ROW, OUTPUT_ITEM_COLUMN), _
    outputSheet.Cells(outputSheet.Columns(OUTPUT_ITEM_COLUMN).Rows.Count, OUTPUT_ITEM_COLUMN)).Select
  Selection.ClearContents
  Dim rowIdx As Long
  'clearing by iterating is much slower
  'For rowIdx = 1 To outputSheet.Columns(LIST_COLUMN_INDEX).Rows.Count
  '  outputSheet.Cells(rowIdx, INPUT_COLUMN_INDEX) = vbNullString
  'Next rowIdx

  Dim item As Variant
  
  rowIdx = OUTPUT_BEGIN_ROW
  Dim previousItem As String
  For Each item In items
    If item <> previousItem Then
      outputSheet.Cells(rowIdx, OUTPUT_ITEM_COLUMN) = item
      rowIdx = rowIdx + 1
    End If
    previousItem = item
  Next item

End Sub  'putDistinctItemsToOutputSheet()
'

' createNamesListsInOutputSheet()
' ===============================

' 2009-06-22 by Geri Broser

Private Sub createNamesListsInOutputSheet(inputBeginRow As Long, inputEndRow As Long)

  Dim outputSheet As Worksheet
  Set outputSheet = ActiveWorkbook.Worksheets(OUTPUT_SHEET)
  
  'clear output range
  outputSheet.Activate
  outputSheet.Range(outputSheet.Cells(OUTPUT_BEGIN_ROW, OUTPUT_NAMES_COLUMN), _
    outputSheet.Cells(outputSheet.Columns(OUTPUT_NAMES_COLUMN).Rows.Count, OUTPUT_NAMES_COLUMN)).Select
  Selection.ClearContents

  Dim inputSheet As Worksheet
  Set inputSheet = ActiveWorkbook.Worksheets(INPUT_SHEET)
  
  Dim outputRowIdx As Long
  Dim item As String
  Dim inputRowIdx As Long
  Dim nameList As String
  Dim names() As String  'array to hold all names
  Dim nameIdx As Long
  Dim name As Variant
  
  outputRowIdx = OUTPUT_BEGIN_ROW
  item = outputSheet.Cells(outputRowIdx, OUTPUT_ITEM_COLUMN)
  
  'loop through output items
  Do While item <> vbNullString
  
    nameList = vbNullString

    nameIdx = 0
    
    'find input names for output item
    For inputRowIdx = inputBeginRow To inputEndRow
      If InStr(inputSheet.Cells(inputRowIdx, INPUT_ITEMS_COLUMN), item) > 0 Then
        ReDim Preserve names(nameIdx)
        names(nameIdx) = inputSheet.Cells(inputRowIdx, INPUT_NAME_COLUMN)
        nameIdx = nameIdx + 1
      End If
    Next inputRowIdx
      
    Call QuickSort(names)
    
    'create separated output list from list array
    For Each name In names
      nameList = nameList & name & OUTPUT_NAMES_SEPARATOR
    Next name
    
    'remove trailing OUTPUT_NAMELIST_SEPARATOR
    outputSheet.Cells(outputRowIdx, OUTPUT_NAMES_COLUMN) = _
      Left(nameList, Len(nameList) - Len(OUTPUT_NAMES_SEPARATOR))
    
    outputRowIdx = outputRowIdx + 1
    item = outputSheet.Cells(outputRowIdx, OUTPUT_ITEM_COLUMN)
    
  Loop
  
End Sub  'createNamesListsInOutputSheet()
'

'From: http://www.vbarchiv.net/tipps/tipp_372-quicksort-in-vb.html

' QuickSort-Algorithmus
'
' vSort() : zu sortierendes Array
' lngStart, lngEnd: zu sortierender Bereich
' ==========================================
Private Sub QuickSort(vSort As Variant, _
  Optional ByVal lngStart As Variant, _
  Optional ByVal lngEnd As Variant)
 
  ' Wird die Bereichsgrenze nicht angegeben,
  ' so wird das gesamte Array sortiert
 
  If IsMissing(lngStart) Then lngStart = LBound(vSort)
  If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
 
  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant
 
  i = lngStart: j = lngEnd
  x = vSort((lngStart + lngEnd) / 2)
 
  ' Array aufteilen
  Do
 
    While (vSort(i) < x): i = i + 1: Wend
    While (vSort(j) > x): j = j - 1: Wend
 
    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      h = vSort(i)
      vSort(i) = vSort(j)
      vSort(j) = h
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)
 
  ' Rekursion (Funktion ruft sich selbst auf)
  If (lngStart < j) Then QuickSort vSort, lngStart, j
  If (i < lngEnd) Then QuickSort vSort, i, lngEnd
  
End Sub 'QuickSort()